Question

我在VBA中正在做一些copy-paste功能。如果cell A1中的值与其他工作簿中的值匹配，则必须复制整行。让我们说（工作表名称是：Sheet1）：

在此工作表中，单元格中的所有值都是工作簿的工作表名称。所以从这本工作书中我得到了这些数据（表名：conso）：

所以我想要做的是找到RangeA中与Cell值匹配的所有值。例如：如果Column A值中的Sheet1与Column A中Conso中的值匹配，那么我必须复制整行并将其粘贴到工作表中sheetName与Column A的{{1}}中的值匹配。提前谢谢。

Answer 1

可能是我没有得到你的确切目标（标题是关于工作簿之间的复制，但你的解释没有提到不同的工作簿和仅处理不同的工作表）但是这里有一个“metacode”我认为你可以遵循到达它

Option Explicit

Sub CopyPaste()
Dim wb1 As Workbook, wb2 As Workbook
Dim shtConso As Worksheet, sht01 As Worksheet, sht As Worksheet
Dim ARng As Range, consoRng As Range, cell As Range
Dim LastRow As Long

Set wb1 = ThisWorkbook      '<== set the workbook where "conso" and "Sheet01" sheets are. here I assume the marco will reside in wb1
Set wb2 = Workbooks("wb2")  '<== set the workbook where data are to be possibly pasted. it has to be already open at the time this macro runs

Set shtConso = wb1.Worksheets("conso") 'set the "conso" sheet, where there are data to be possibly copied
Set sht01 = wb1.Worksheets("Sheet01") 'set the "Sheet01" sheet, where there are wb2 sheet names

Set ARng = sht01.  ... ' set the range in "Sheet01" with wb2 sheets names
Set consoRng = shtConso.   ...'set the range in "conso" with wb2 sheets names

For Each cell In ARng 'loop through sheet names to be found in wb2

    Set sht = SetSheet(wb2, cell.Value) 'search for wb2 sheet. see the function skeleton below
    If Not sht Is Nothing Then ' if found '....

        LastRow = GetLastRow(sht, 1) '... get its last non empty row in column A. see the function skeleton below

        With consoRng
            .AutoFilter .... 'now use .Autofilter method on "consoRng" range to select rows that matches cell.Value
            With .SpecialCells(xlCellTypeVisible) ' consider only filtered rows
                ' check if there are any... maybe using a "Find" method on this filtered range

                ' ... and if there are, copy the entire row (use .EntireRow property on the filtered range) and paste them to wb2sheet (use wb2 and lastRow variables)
            End With
            .AutoFilter ' disable autofilter to have the entire range still available
        End With
    End If
Next

End Sub


Function SetSheet(wb As Workbook, shtName As String) As Worksheet
' write a simple function that that try and set a sheet with the given name in the given workbook
' if it succeed it returns that sheet
' if it fails then it returns "nothing"

End Function


Function GetLastRow(sht As Worksheet, col As Long) As Long
' write a simple function that returns the row of the last non empty cell of the given column in the given worksheet
' use ".End(xlUp)" method of the "Range" object
' handle the cases where either the column has no values or its last non empty cell is in the very last row of that column

End Function

Answer 2

我在代码中尝试解释，但我相信它完全符合您的要求。

 Option Explicit
 Sub CopyDataFromOneWorkBookToAnother()
      'Setting up Reference to the Data WorkSheet
      Dim DataBaseSheet As Worksheet
      Set DataBaseSheet = Workbooks("Database WorkBook.xlsx").Sheets("conso")

      'Setting up Reference to the OtherWorkBook
      Dim SearchCriteriaSheet As Worksheet
      Set SearchCriteriaSheet = Workbooks("BookName.xlsm").Sheets("Sheet1")

      Dim LastRowSearchCriteria As Long
      LastRowSearchCriteria = SearchCriteriaSheet.Cells(SearchCriteriaSheet.Rows.Count, "A").End(xlUp).Row

      Dim SearchCriteriaRange As Range
      SearchCriteriaSheet.Activate
      Set SearchCriteriaRange = SearchCriteriaSheet.Range(Cells(1, "A"), Cells(LastRowSearchCriteria, "A"))


      Dim SearchValue As Range
      Dim SingleSearchCriteria As String
      Dim DataBaseFoundRange As Range
      Dim SearchRange As Range
      Dim FoundDataRowReference As Range
      Dim SingleFoundRange As Range
      Dim LastColumInFoundDataRow As Long
      Dim PastedRowCounter As Long
      Dim LastCellofSearchRange As Range
      Dim FirstAddress As String


      For Each SearchValue In SearchCriteriaRange

           SingleSearchCriteria = SearchValue.Value

           DataBaseSheet.Activate
           Set SearchRange = DataBaseSheet.Columns("A:A")

           'For use in the .Find After:=
           'This enables the search to start at the Top of the Column
           'Otherwise it skips the initial cell
           With SearchRange
                Set LastCellofSearchRange = .Cells(.Cells.Count)
           End With

           Set DataBaseFoundRange = SearchRange.Find(what:=SingleSearchCriteria, After:=LastCellofSearchRange, _
                                                     LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                                                     SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

           'To reference the row to paste the data to
           PastedRowCounter = 1

           'Setting the First Found address in order to know when to quit the Loop
           If Not DataBaseFoundRange Is Nothing Then
                FirstAddress = DataBaseFoundRange.Address
           End If


           Do Until DataBaseFoundRange Is Nothing

                LastColumInFoundDataRow = DataBaseSheet.Cells(DataBaseFoundRange.Row, Columns.Count).End(xlToLeft).Column
                Set SingleFoundRange = DataBaseSheet.Range(Cells(DataBaseFoundRange.Row, "B"), Cells(DataBaseFoundRange.Row, LastColumInFoundDataRow))
                SingleFoundRange.Copy
                Workbooks("BookName.xlsm").Sheets(DataBaseFoundRange.Value).Cells(PastedRowCounter, "A").PasteSpecial Paste:=xlPasteValues


                Set DataBaseFoundRange = SearchRange.FindNext(After:=DataBaseFoundRange)
                If DataBaseFoundRange.Address = FirstAddress Then
                     Exit Do
                End If

                PastedRowCounter = PastedRowCounter + 1
           Loop

      Next SearchValue

End Sub

使用搜索条件对WorkBook进行快照，这也是粘贴数据的工作簿，其中包含“B1”，“B2”等表单。

“数据库”工作簿的快照，其中包含A列中的B1，B2参考

下面的代码结果，其中A列中B1的行中的数据基于工作表B1，然后是sam eiwth B2等等

将数据从一个工作簿复制到另一个工作簿

2 个答案: