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

Question

我有复制值并为我提供值的代码，但没有我需要的代码。我感觉自己很亲密，但缺少某些东西。代码将复制工作簿的整个工作表，并且我需要符合条件的值。

我有这个主要工作簿，我想从具有相同格式的不同工作簿中获取信息，例如，这个，并且我想在主要工作簿中将值粘贴到根据前三列（“ 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