Как исправить 'Поля не заполняются при создании набора записей из книги с двумя строками заголовка'

Question

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

Код ранее работал для рабочих книг только с одной строкой заголовка строки (со всеми остальными данными под ним, являющимися числовыми данными), но теперь я сталкиваюсь с трудностями с рабочими книгами, которые имеют две строки заголовка строк. Если я удаляю одну из первых двух строк строк в книге и пытаюсь запустить, макрос работает нормально и поля заполняются правильно. Однако это нереальное долгосрочное решение.

Dim Header As Boolean
Dim rsCon As Object
Dim rsData As Object
Dim szSQL As String
Dim szConnect As String
Dim sDFolder As String
Dim SourceFile As String

Header = True

'Folder that contains several workbooks
sDFolder = "C:\Users\kevin\Desktop\Test"

'Example File from sDFolder
SourceFile = "Data 2019-02-25.csv"

' Create the connection string
szConnect = "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
            "Dbq=" & sDFolder & ";" & _
            "Extensions=asc,csv,tab,txt;"

' workbook level name
szSQL = "SELECT * FROM " & """" & SourceFile & """"

Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")

rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1   'adOpenForwardOnly, adLockReadOnly, adCmdText

If Not rsData.EOF Then
    If Header = True Then
        TargetRange.Cells(1, 1).CopyFromRecordset rsData
    End If    
End If

rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
SetAttr sDFolder, vbNormal

Приведенный выше код работает для книг с одним заголовком, но поля в rsData не заполняются правильно для книг с двумя заголовками.

Answer 1

' First--Open the CSV and detect is there are duplicate Headers
'   If dupes, then copy from line2 forward to the end to a temp file
'   At end, delete the original file, and rename temp to original name

Sub RemoveDuplicateHeader(strPath As String, strFile As String)
    ' open the csv file
    f1 = FreeFile
    Open strPath & strFile For Input As #f1 ' Open file for input

    Line Input #f1, line1
    Line Input #f1, strLine

    ' If there are duplicate Header rows, then remove one
    If line1 = strLine Then
        f2 = FreeFile
        Open strPath & "Temp_" & strFile For Output As #f2
            Print #f2, strLine
        Do While Not EOF(f1)
            Line Input #f1, strLine
            Print #f2, strLine
        Loop
        Close #f1 ' Close file
        Close #f2

        If Dir(strPath & "Temp_" & strFile) <> "" Then
            Kill strPath & strFile
            Name strPath & "Temp_" & strFile As strPath & strFile
        End If

    Else
        Close #f1 ' Close file

    End If

End Sub