如果零件号存在于两张图纸中，是否将数据范围从一张图纸复制到另一张图纸？

Question

我有两份文件。一个get每天更新并发送电子邮件。另一个是我想要添加按钮/宏的"Master“文件。也就是说，当在主文件中运行Macro时，我想要查看每日更新文件上的B列。如果在日常文件和主文件(H列)的B列(表"Status")中都存在部件号，则从AK列开始，将C-N列粘贴到主文件(表"XCHART")中

Sub CopyRange()
Dim a As Worksheet
Dim b As Worksheet
Dim rng As Range
'open the workbooks
Workbooks.Open "D:\OfficeDev\Excel\201510\Master.xlsx"
Set a = Workbooks("Master.xlsx").Worksheets("Sheet1")    
Workbooks.Open "D:\OfficeDev\Excel\201510\MasterBak.xlsx"
Set b = Workbooks("MasterBak.xlsx").Worksheets("Sheet1")
'loop the cells in column B
For r = 2 To a.UsedRange.Rows.Count
    If Trim(a.Cells(r, 2)) <> "" Then
        With b.Range("B:B")
            Set rng = .Find(What:=a.Cells(r, 2), _
                    After:=.Cells(.Cells.Count), _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
            If Not rng Is Nothing Then
                'write code to copy the cells
                Debug.Print a.Cells(r, 2)
            End If
        End With
    End If
Next

结束子对象

Answer 1

我已经尝试了一个使用Dictionary对象的解决方案，我认为它符合您的要求。Dictionay方法限制部件号是唯一的，即不能重复。我还上传了一个示例文件，供您细读和调整。此Sampl File

请尝试以下操作：

Sub CopyData()
    Dim j As Integer
    Dim k As Integer
    For j = 1 To 12
      Call CopyDataB(j) ' Call subroutine to transfer column values for matching Part No
    Next
End Sub

Sub CopyDataB(j)
    Dim Dic As Object, key As Variant, nCell As Range, i&
    Dim w1 As Worksheet, w2 As Worksheet
    Dim k As Integer
    Dim l As Integer
       Set Dic = CreateObject("Scripting.Dictionary") ' Create Dictionary Object Dictionary contains unique keys with data item
       Set w1 = Workbooks("FAIMAIN.xlsx").Sheets("Status") 'Workbook which is daily updated
       Set w2 = Workbooks("Master.xlsm").Sheets("XCHART") ' Master Workbook
       k = 29 ' set number to suit your column number requirements
       k = l + k ' Another integer variable added to enable proper looping of column offset
       i = w1.Cells.SpecialCells(xlCellTypeLastCell).Row

           For Each nCell In w1.Range("B2:N" & i)
               If Not Dic.exists(nCell.Value) Then
                 Dic.Add nCell.Value, nCell.Offset(, j).Value 'Dictionary adds Partno unique keys along with column data
               End If
           Next

      i = w2.Cells.SpecialCells(xlCellTypeLastCell).Row

          For Each nCell In w2.Range("H2:H" & i)
             For Each key In Dic
                If nCell.Value = key Then
                  nCell.Offset(, j + 28).Value = Dic(key) 'Dictionary key is matched and column value is written
                  l = l + 1
                End If
             Next
          Next
End Sub