匹配两个excel工作表上的列并复制数据答案

【问题标题】：Match Columns on two excel worksheets and copy data匹配两个excel工作表上的列并复制数据
【发布时间】：2013-04-04 16:35:53
【问题描述】：

我在同一个 Excel 文件中有两个数据表： Sheet1 作为“数据”，有 7 列：

第二张表是“主要”，有 5 列：

匹配两个文件的同一列是“名称”。我想要一个与两个工作表上的名称匹配的 VBA 代码，并通过匹配两个工作表上的列名来将数据从 proc1 - Proc4 从工作表“Main”复制到工作表“数据”。

我在堆栈溢出中搜索了类似的问题，这是我找到的代码（稍作修改）：

Sub CopyData()

Dim shtImport As Worksheet
Dim shtMain As Worksheet
Set shtImport = ThisWorkbook.Sheets("Data")
Set shtMain = ThisWorkbook.Sheets("Main")

    Dim CopyColumn As Long
    Dim CopyRow As Long
    Dim LastColumn As Long

    '- for each column in row 1 of import sheet
    For CopyColumn = 1 To shtImport.Cells(1, shtImport.Columns.Count).End(xlToRight).Column
    '- check what the last column is with data in column
    LastRowOfColumn = shtImport.Cells(shtImport.Columns.Count, CopyColumn).End(xlToRight).Column
    'if last column was larger than one then we will loop through rows and copy
    If LastColumn > 1 Then
    For CopyRow = 1 To LastColumn
    '- note we are copying to the corresponding cell address, this can be modified.
    shtMain.Cells(CopyRow, CopyColumn).value = shtImport.Cells(CopyRow, CopyColumn).value
    Next CopyRow
    End If
    Next CopyColumn

    End Sub

这不是我想要的工作方式。有人可以帮我解决这个问题。非常感谢！

【问题讨论】：

我之前也问过类似的问题，但不是在寻找特定的列名而是列号。可以修改此代码以包含列名。我不确定，但认为在此处引用此内容会有所帮助：stackoverflow.com/questions/14689156/…

标签： vba excel excel-2007

【解决方案1】：

试试这个代码：

Sub CopyData()

Dim shtImport As Worksheet
Dim shtMain As Worksheet
Set shtImport = ThisWorkbook.Sheets("Data")
Set shtMain = ThisWorkbook.Sheets("Main")

'From Main to Data
Dim rngImpTitles As Range
Set rngImpTitles = shtImport.Rows(1)
Dim rngImpNames As Range
Set rngImpNames = shtImport.Columns(1)

Dim CopyColumn As Long
Dim CopyRow As Long
Dim foundRow As Long
Dim foundCol As Long

On Error Resume Next
'for each column in row 1 of import sheet
For CopyColumn = 2 To shtMain.Cells(1, shtMain.Columns.Count).End(xlToLeft).Column
    foundCol = rngImpTitles.Find(shtMain.Cells(1, CopyColumn).Value2).Column
    If Err.Number <> 0 Then
        MsgBox "Not such a col title in importsheet for " & vbNewLine & _
                        shtMain.Cells(1, CopyColumn)
        Err.Clear
        GoTo skip_title
    End If


    For CopyRow = 2 To shtMain.Cells(shtMain.Rows.Count, 1).End(xlUp).Row
        foundRow = rngImpNames.Find(shtMain.Cells(CopyRow, 1)).Row
        If Err.Number <> 0 Then
            MsgBox "Not such a row name in importsheet for " & vbNewLine & _
                        shtMain.Cells(CopyRow, 1)
            Err.Clear
            GoTo skip_row
        End If

            If Len(shtMain.Cells(CopyRow, CopyColumn)) <> 0 Then
                    shtMain.Cells(CopyRow, CopyColumn).Copy shtImport.Cells(foundRow, foundCol)
            End If

skip_row:
    Next CopyRow
skip_title:
Next CopyColumn

End Sub

【讨论】：