Блог

Я пытаюсь сопоставить определенные листы с «Отчетом» в их названиях в разных файлах Excel и вставить их в новый документ Excel, при этом данные каждого нового листа вставляются под последней используемой строкой сопоставленного листа. Мне также нужно проверить наличие отсутствующих заголовков в разных файлах Excel и добавить заголовок в соответствующее место, если он отсутствует. Я объединил коды vba, которые нашел в Интернете, но все еще не могу заставить их работать.Во-первых, отсутствующие столбцы не добавляются при запуске кода. Далее, я не слишком уверен в том, как написать via для копирования и вставки в последнюю используемую строку первого листа.

     Sub AddMissingHeader()
    Dim headers() As Variant
    headers = Array("Report_Date", "Company", "Customer_Id", "Product_Id", "Company_Name")
    Dim i As Long
    For i = LBound(headers) To UBound(headers)
        If Cells(5, i   1).Value <> headers(i) Then
            Columns(i   1).EntireColumn.Insert
            Cells(5, i   1).Value = headers(i)
        End If
    Next i
    End Sub

Sub SelectAndCopy()

Dim i As Integer

WS_Count = ActiveWorkbook.Worksheets.Count
For i = 2 To WS_Count
    Worksheets(i).Select
    Range("A3:M3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("Sheet1").Select
    Dim lstrow As Integer
    'finds the last row
    lstrow = ActiveSheet.UsedRange.Rows.Count
    ActiveSheet.Range("A" amp; lstrow).Offset(1).Select
    ActiveSheet.Paste
Next i

End Sub

Sub Collate()


Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = InputBox("Please copy and paste the path to the folder containing the source documents")
Set wbDst = ActiveWorkbook
strFilename = Dir(MyPath amp; "*Report*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
    Set wbSrc = Workbooks.Open(Filename:=MyPath amp; "" amp; strFilename)
    For Each ws In wbSrc.Worksheets
        If InStr(1, ws.Name, "New amp; Continuing", vbTextCompare) Then
            Set wsSrc = ws
            Call AddMissingHeader
        End If
    Next ws
    wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
    wbSrc.Close False
    strFilename = Dir()
Loop
Call SelectAndCopy

End Sub