如何根据多个条件从不同的工作簿中复制值？

Question

我有代码可以复制值并给我提供值，但不是我需要的值。我觉得我很接近，但缺少一些东西。该代码复制了工作簿的整个工作表，我需要符合条件的值。

我有这个主工作簿and i want to take Information from different workbooks which have the same Format, for example this ，我想在主工作簿中根据前三列中的条件粘贴某个范围内的值 ("SSL"; "Baureihe";"Produktionsjahr")

这是我到目前为止所做的代码


    Sub Transfer ()
    
    Dim SSl As String
    Dim Baureihe As String
    Dim Produktionsjahr As String
    Dim fileName As String
    Dim Tfile As Workbook
    Dim shData As Worksheet, shOutput As Worksheet
    Dim rg As Range, ra As Range
    Dim i As Long, row As Long, j As Long
    Set shData = ThisWorkbook.Worksheets("Transponieren")
    
    filename = Application.getOpenFilename("Excel file (*.xlsm),*.xlsm", , "Select File")
    
    If filename = Empty then
     Exit Sub
    End If
    
    Set Tfile = Application.Workbooks.Open(filename)
    Set shOutput = Tfile.Worksheets("Transponieren")
    Set rg = shData.Range("A1").CurrentRegion
    Set ra = shOutput.range("A1").CurrentRegion
    
    
    row = 2
    
    For i = 2 To rg.Rows.Count

            SSL = Sheets("Transponieren").Cells(i, 1).Value
            Baureihe = Sheets("Transponieren").Cells (i , 2).Value
            Produktionsjahr = Sheets("Transponieren") .Cells(i, 3).Value

        For j = 2 To ra.Rows.Count
    
            If ra.Cells(j, 1).Value = SSL And _
            ra.Cells(j, 2).Value = Baureihe And _
            ra.Cells(j, 3).Value = Produktionsjahr Then

   Tfile.Sheets("Transponieren").Range("A" & i & ":E" & i).Copy _ 
  Destination:=ThisWorkbook.Sheets("Transponieren").Range("K" & j & ":O" & j)

     row = row + 1
     Application.CutCopyMode = False

            End if
        Next j
    Next i
     
    End Sub

我是 vba Excel 的新人，我尝试了各种方法，但我似乎无法理解为什么此代码不只复制我需要的值。提前致谢

Answer 1

这是帮助我完成任务的代码。正好有人需要。

Option Explicit

Sub transfer()
 Dim fileName As Variant, a() As Variant, b() As Variant, c As Variant, i As Long, j As Long
 Dim sh1 As Worksheet, wb2 As Workbook, sh2 As Worksheet
 '
 Application.ScreenUpdating = False
 Set sh1 = Sheets("Transponieren")

 fileName = Application.GetOpenFilename("Excel file (*.xlsx),*.xlsx", , "Select File")
 If fileName = False Then Exit Sub
 Set wb2 = Application.Workbooks.Open(fileName)
 Set sh2 = wb2.Sheets("Transponieren")
 `
 a = sh1.Range("A2:C" & sh1.Range("A" & Rows.Count).End(xlUp).row)
 b = sh2.Range("A2:E" & sh2.Range("A" & Rows.Count).End(xlUp).row)
 ReDim c(1 To UBound(a), 1 To 5)
 For i = 1 To UBound(a)
   For j = 1 To UBound(b)
     If a(i, 1) = b(j, 1) And a(i, 2) = b(j, 2) And a(i, 3) = b(j, 3) Then
       c(i, 1) = b(j, 1)
       c(i, 2) = b(j, 2)
       c(i, 3) = b(j, 3)
       c(i, 4) = b(j, 4)
       c(i, 5) = b(j, 5)
       Exit For
     End If
   Next
 Next
 wb2.Close False
 sh1.Range("K2").Resize(UBound(a), 5).Value = c
End Sub

如何根据多个条件从不同的工作簿中复制值？

How can i copy values from different workbook based on multiple criterias?

excel

vba

excel-2016