Как исключить столбцы по имени при импорте нескольких xml-файлов в Excel с VBA?

Question

Мне удалось создать макрос, который импортирует несколько xml-файлов в отдельные таблицы. Проблема в том, что некоторые таблицы содержат один дополнительный столбец. Я хочу, чтобы имена столбцов были в одном столбце для всех таблиц.

Я использую VBA, и у меня нет такого большого опыта с этим.

Sub CommandButton1_Click()

    Dim xWb As Workbook
    Dim xSWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xCount As Long
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Application.ScreenUpdating = False
    Set xSWb = ThisWorkbook
    xCount = 1
    xFile = Dir(xStrPath & "\*.xml")
    Do While xFile <> ""
        Set xWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
        xWb.Sheets(1).UsedRange.Copy xSWb.Sheets(1).Cells(xCount, 1)
        xWb.Close False
        xCount = xSWb.Sheets(1).UsedRange.Rows.Count + 2
        xFile = Dir()
    Loop
    Application.ScreenUpdating = True
    xSWb.Save

On Error Resume Next
Columns("D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Exit Sub


ErrHandler:
    MsgBox "no files xml", , "Kutools for Excel"

End Sub

Answer 1

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

Обратите внимание, что когда вы удаляете что-то, вы всегда должны делать это с конца до начала.

Dim startRow As Long
startRow = 1
xFile = Dir(xStrPath & "\*.xml")
Do While xFile <> ""
    Set xWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
    With xWb.Sheets(1)
        Dim lastCol As Long, col As Long
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ' Loop over all columns from right to left 
        For col = lastCol To 1 Step -1
            ' Throw the extra column away
            If .Cells(1, col) = "YourUnwantedCol" Then
                .Cells(1, col).EntireColumn.Delete
            End If
        Next col

        ' Now copy the data 
        .UsedRange.Copy xSWb.Sheets(1).Cells(startRow, 1)
        startRow = startRow + .UsedRange.Rows.Count
        ' Close without saving, don't show a warning.
        Application.DisplayAlerts = False
        xWb.Close False
        Application.DisplayAlerts = True

        xFile = Dir()
    End With
Loop

Answer 2

Sub CommandButton2_Click()

Dim xWb As Workbook
    Dim xSWb As Workbook
    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    Dim xCount As Long
    On Error GoTo ErrHandler
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    Application.ScreenUpdating = False
    Set xSWb = ThisWorkbook
    xCount = 1
    xFile = Dir(xStrPath & "\*.xml")



    Dim startRow As Long
startRow = 1
xFile = Dir(xStrPath & "\*.xml")
Do While xFile <> ""
    Set xWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
    With xWb.Sheets(1)
        Dim lastCol As Long, col As Long
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ' Loop over all columns from right to left
        For col = lastCol To 1 Step -1
            ' Throw the extra column away
            If .Cells(1, col) = "Content" Then
                .Cells(1, col).EntireColumn.Delete
            End If
        Next col

        ' Now copy the data
        .UsedRange.Copy xSWb.Sheets(1).Cells(startRow, 1)
        startRow = startRow + .UsedRange.Rows.Count
        ' Close without saving, don't show a warning.
        Application.DisplayAlerts = False
        xWb.Close False
        Application.DisplayAlerts = True

        xFile = Dir()
    End With
Loop

    Application.ScreenUpdating = True
    xSWb.Save

'Removes rows with no "event id"
On Error Resume Next
Columns("D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Exit Sub


ErrHandler:
    MsgBox "no files xml", , "Kutools for Excel"

End Sub