Excel 2013 - 如何根据格式将数据从一个工作表复制到另一个工作表

I have an Excel sheet with values, and I want to automatically copy only the values that are highlighted (formatted with background color) to another sheet. I don't mind using a macro, or if possible a function in the second sheet cells.

我有一个带有值的Excel工作表,我想自动仅将突出显示的值(使用背景颜色格式化)复制到另一个工作表。我不介意使用宏,或者如果可能的话,在第二个单元格中使用一个函数。

I've tried to put a few suggestions together and created a function to return the cell color and this following macro to filter by the color value:

我试图将一些建议放在一起并创建一个函数来返回单元格颜色,然后通过颜色值过滤下面的宏:

Sub Sample()
    Dim ws As Worksheet
    Dim strSearch As String
    Dim lRow As Long

    Set ws = Sheets("Sheet1")

    With ws
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        '~~> Remove any filters
        .AutoFilterMode = False

        '~~> Filter, offset(to exclude headers) and set the source location
        With .Range("J2:J" & lRow)
             .AutoFilter Field:=1, Criteria1:="6"
             Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With

    '~~> Destination Sheet
    Set ws2 = Sheets("Sheet2")
    With ws2
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
        Else
            lRow = 1
        End If

        copyFrom.Copy .Rows(lRow)
    End With
End Sub

Function InteriorColor(CellColor As Range)
    InteriorColor = CellColor.Interior.ColorIndex
End Function

But, I need to copy from several sheets to a single sheet, and the macro states that the source sheet is constant... I wouldn't want to create a macro for each separate sheet.

但是,我需要从几张纸复制到一张纸,宏指出源纸张是常量...我不想为每张单独的纸张创建一个宏。

In addition, each time I will run the macro, it will copy the highlighted lines which were already copied before thus creating duplicates in the destination sheet.

此外,每次我将运行宏时,它将复制已经复制的突出显示的行,从而在目标表中创建重复项。

I've looked into many SO posts regarding this issue but couldn't find anything that suits my needs.

我已经查看了很多有关此问题的SO帖子,但找不到任何适合我需求的帖子。

Can anyone suggest how to change this code or have a new optimized one?

任何人都可以建议如何更改此代码或有一个新的优化代码?

Thank you in advance!

先感谢您!

1 个解决方案

#1

First off, I think this should be separated into two problems:

首先,我认为这应该分为两个问题:

Import from different worksheets

If you want to import from different sheets, you should write your function to accept a sheet as a parameter.

如果要从不同的工作表导入,则应编写函数以接受工作表作为参数。

Sub Sample(ws As Excel.Worksheet)

Then you need to remove both the lines Dim ws As Worksheet and Set ws = Sheets("Sheet1"), or you will get an error or unexpected behavior.

然后你需要删除线条Dim ws As Worksheet和Set ws = Sheets(“Sheet1”),否则你将收到错误或意外行为。

Then you need another function that loops through all the worksheets and calls your Sample(Worksheet) procedure.

然后你需要另一个循环遍历所有工作表的函数并调用你的Sample(工作表)程序。

Sub SampleCaller()
  dim e, ws as Excel.Worksheet
  For Each e in ThisWorkbook.Sheets
    Set ws = e
    Call Sample(ws)
  Next e
  Set ws = Nothing
End Sub

Find already existing rows in destination worksheet

You are already using the Range.Find method (Link).
You can use it to find already existing elements in your destination worksheet.
Before Calling copyFrom.Copy .Rows(lRow) you should use Range.Find to determine whether you need to copy this value.

您已经在使用Range.Find方法(链接)。您可以使用它来查找目标工作表中已有的元素。在调用copyFrom.Copy .Rows(lRow)之前,您应该使用Range.Find来确定是否需要复制此值。

Maybe you should create another topic for this second issue, or use the search function.

也许您应该为第二个问题创建另一个主题,或使用搜索功能。