Блог

 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 " amp; numRowsToCopy
    
Dim destRowOffset As Long
 
    destRowOffset = ws2.Cells(RowIndex:=Rows.Count, ColumnIndex:=1).End(xlUp).Row
    'MsgBox "The next Blank row is " amp; 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 amp; vbNewLine amp; 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:" amp; vbNewLine amp; msg
    End If
Exit Sub

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

End Sub
 

Этот код работает отлично, но я не могу выполнить два условия:-

1. Конечный excel имеет заголовок столбца во второй строке. Я не могу сравнить заголовок столбца во второй строке и вставить данные из третьей строки
2. я не могу прочитать исходный файл в формате csv, и я хочу указать путь пользователя, как я могу это сделать .

Добро пожаловать в стек. Предполагая, что вы не писали этот код самостоятельно, вам нужно будет быть готовым учиться, если вам нужна наша помощь. Тем не менее, все начинается сложно, поэтому, предполагая, что вы просто хотите скопировать столбцы из CSV на основе ограниченного списка предопределенных заголовков, сценарий, который вы опубликовали, является полным перебором imho. Поэтому я предлагаю использовать это в качестве нашей базы:

     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
 

Это еще не делает то, что вы хотите, но это должно вывести вас на правильный путь. Заполните приведенный выше код и опубликуйте его снова, если вам нужна дополнительная помощь.