Как я могу скопировать значения из другой книги на основе нескольких критериев? - PullRequest
Новая
       18

Как я могу скопировать значения из другой книги на основе нескольких критериев?

0 голосов
/ 17 октября 2019

У меня есть код, который копирует значения и дает мне значения, но не тот, который мне нужен. Я чувствую, что я рядом, но чего-то не хватает. Код копирует весь рабочий лист рабочей книги, и мне нужны значения, соответствующие критериям.

У меня есть эта основная рабочая книга Main Workbook, и я хочу взять информацию из разных рабочих книг, которые имеюттот же формат, например этот one, и я хочу в основной рабочей книге вставить значения в некотором диапазоне на основе критериев в первых трех столбцах ("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, я пробовал разные способы, но я могу 'Кажется, я не понимаю, почему этот Кодекс не копирует только те значения, которые мне нужны. Заранее спасибо

1 Ответ

0 голосов
/ 21 октября 2019

Это Кодекс, который помог мне закончить мои задания. Просто если кому-то нужно. 

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
...