如果列 header 匹配，如何将数据从 csv 表复制到 excel 表

Question

Option Explicit

Function GetHeadersDict() As Scripting.Dictionary
' We must activate the Microsoft Scripting Runtime from Tools --References

Dim result As Scripting.Dictionary

    Set result = New Scripting.Dictionary

    With result
     
        .Add "Name", False
        .Add "Mobile", False
        .Add "Phone", False
        .Add "City", False
        .Add "Designation", False
        .Add "DOB", False
        
    End With

    Set GetHeadersDict = result
    
End Function

Function FindHeaderRange(ByVal ws As Worksheet, ByVal header As String) As Range

    Set FindHeaderRange = ws.Cells.Find(header, , , xlWhole)
    
End Function

Sub clearDataSheet2()

Sheets("Destination").Range("A1").CurrentRegion.Offset(1).ClearContents

End Sub


Sub copyColumnData()


On Error GoTo ErrorMessage
    
Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Source")
    Set ws2 = ThisWorkbook.Sheets("Destination")
    
    clearDataSheet2

Dim numRowsToCopy As Long

    numRowsToCopy = ws1.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row - 1
    'MsgBox "The no of rows to copy is " & numRowsToCopy
    
Dim destRowOffset As Long
 
    destRowOffset = ws2.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row
    'MsgBox "The next Blank row is " & destRowOffset

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    
Dim dictKey As Variant
Dim header As String
Dim numColumnsToCopy As Long
Dim source As Range
Dim dest As Range

Dim headersDict As Scripting.Dictionary

    Set headersDict = GetHeadersDict()

    For Each dictKey In headersDict
        header = dictKey
        If headersDict.Item(header) = False Then
            Set source = FindHeaderRange(ws1, header)
            If Not (source Is Nothing) Then
                Set dest = FindHeaderRange(ws2, header)
                If Not (dest Is Nothing) Then
                    headersDict.Item(header) = True
                    ' Look at successive headers to see if they match
                    ' If so, copy these columns altogether to make the macro faster
                    For numColumnsToCopy = 1 To headersDict.Count
                        'MsgBox numColumnsToCopy
                        If source.Offset(ColumnOffset:=numColumnsToCopy).Value = dest.Offset(ColumnOffset:=numColumnsToCopy).Value Then
                            headersDict.Item(source.Offset(ColumnOffset:=numColumnsToCopy).Value) = True
                            
                        Else
                            Exit For
                        End If
                        
                    Next numColumnsToCopy

                    source.Offset(RowOffset:=1).Resize(RowSize:=numRowsToCopy, ColumnSize:=numColumnsToCopy).Copy _
                        dest.Offset(RowOffset:=destRowOffset)
                End If
            End If
        End If
    Next dictKey

Dim msg As String

    For Each dictKey In headersDict
        header = dictKey
        If headersDict.Item(header) = False Then
            msg = msg & vbNewLine & header
        End If
    Next dictKey

ExitSub:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    If msg Not Equal To "" Then
        MsgBox "The following headers were not copied:" & vbNewLine & msg
    End If
Exit Sub

ErrorMessage:
    MsgBox "An error has occurred: " & Err.Description
    Resume ExitSub

End Sub

此代码完美运行，但我无法满足两个条件：-

1. 目标 excel 在第二行有列 header。 我无法比较第二行中的 header 列并粘贴第三行的数据
2. 我无法将源文件读取为 csv 并且我想由用户提供路径我该怎么做。

Answer 1

欢迎堆叠。 假设您没有自己编写此代码，如果您需要我们的帮助，您需要愿意学习。 也就是说，一切开始都很困难，所以假设您只想根据预定义标题的有限列表从 CSV 复制列，那么您发布的脚本完全是矫枉过正。 所以我建议以此为基础：

    Option Explicit
    Sub move()
        Dim arr, arr2, j As Long, i As Long
        arr = Sheet1.Range("A1").CurrentRegion.Value2 'get the source, we'll replace this with the csv import later
        ReDim arr2(1 To UBound(arr), 1 To UBound(arr, 2)) 'setup the destination array
        For j = 1 To UBound(arr) 'rows, start at the header row
            For i = 1 To UBound(arr, 2) 'columns
                Select Case arr(1, i)
                    Case "Name" 'the column names we want to match
                        arr2(j, 1) = arr(j, i)
                    'Add the rest of your cols here with Case colname
                End Select
            Next i
        Next j
        With Sheet2
            .Range(.Cells(1, 1), .Cells(UBound(arr2), UBound(arr2, 2))).Value2 = arr2 'dump to sheet, if you want your destination to start at row 3 change it here
        End With
    End Sub

它还没有做你想做的事，但它应该让你走上正确的道路。 如果您需要更多帮助，请完成上面的代码并再次发布。