在导入多个XML文件以与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