VBA 根據條件將數據從一個工作簿復制到另一個工作簿中的特定單元格

Question

我有 2 個工作簿，需要將第 26 列中為“是”的行中的數據復制到目標工作簿中的特定單元格。 我目前將以下代碼附加到源表上的按鈕上：

Sub exportData()

Dim LastRow As Integer 
Dim i As Integer
Dim erow As Integer

LastRow = ActiveSheet.Range("A" & rows.Count).End(xlUp).Row

For i = 2 To LastRow

If Cells(i, 26).Value = "Yes" Then


    Range(Cells(i, 1), Cells(i, 26)).Select
     Selection.Copy

    Workbooks.Open Filename:=ThisWorkbook.Path & "\GI New Starter Tracker 2017edit.xlsx"
    Worksheets("Main").Select
    erow = ActiveSheet.Cells(rows.Count, 1).End(xlUp).Offset(1, 0).Row

    ActiveSheet.Cells(erow, 1).Select

    ActiveSheet.Paste
    'ActiveSheet.Range("$A$1:$AB$3000").RemoveDuplicates Columns:=2, Header:=xlYes
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Application.CutCopyMode = False


End If
Next i
End Sub

代碼工作正常，但是它復制了整行，但我只需要復制某些信息，如“名字”、“姓氏”、“出生日期”。 目標工作簿沒有完全相同的標題，所以我需要能夠指定哪一列。

我一直在拉我的頭發，非常感謝任何幫助。

謝謝 ：）

Answer 1

這應該這樣做。 您需要將列號更改為工作簿中的相應列....

Sub exportData()

    Dim LastRow As Integer
    Dim i As Integer
    Dim erow As Integer
    Dim wbk As Workbook
    Dim SourceSheet As Worksheet
    Dim DestSheet As Worksheet
    Dim firstName, surName, DoB

    Set SourceSheet = ActiveSheet
    LastRow = SourceSheet.Range("A" & Rows.Count).End(xlUp).Row
    Set wbk = Workbooks.Open(ThisWorkbook.Path & "\GI New Starter Tracker 2017edit.xlsx")
    Set DestSheet = wbk.Sheets("Main")

    For i = 2 To LastRow
        If SourceSheet.Cells(i, 26).Value = "Yes" Then
            'change the column numbers to the relevant number
            firstName = SourceSheet.Cells(i, 23).Value
            surName = SourceSheet.Cells(i, 24).Value
            DoB = SourceSheet.Cells(i, 25).Value

            erow = DestSheet.Cells(DestSheet.Rows.Count, 1).End(xlUp).Offset(1, 0).Row

            'change the column numbers to the relevant number
            DestSheet.Cells(erow, 10).Value = firstName
            DestSheet.Cells(erow, 11).Value = surName
            DestSheet.Cells(erow, 12).Value = DoB
        End If
    Next i

    wbk.Save
    wbk.Close
End Sub