如何根据多个条件从不同的工作簿中复制值?
How can i copy values from different workbook based on multiple criterias?
我有代码可以复制值并给我提供值,但不是我需要的值。我觉得我很接近,但缺少一些东西。该代码复制了工作簿的整个工作表,我需要符合条件的值。
我有这个主工作簿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 的新人,我尝试了各种方法,但我似乎无法理解为什么此代码不只复制我需要的值。提前致谢
这是帮助我完成任务的代码。正好有人需要。
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
我有代码可以复制值并给我提供值,但不是我需要的值。我觉得我很接近,但缺少一些东西。该代码复制了工作簿的整个工作表,我需要符合条件的值。
我有这个主工作簿
这是我到目前为止所做的代码
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 的新人,我尝试了各种方法,但我似乎无法理解为什么此代码不只复制我需要的值。提前致谢
这是帮助我完成任务的代码。正好有人需要。
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