Question

我在Excel 2007下面有一个宏代码。我需要将.xml文件导入Excel。有1,000个.xml文件。架构只有80％相同。我需要将它们导入Excel并以分号形式导出为.csv。我已将代码插入Excel宏。但是当我执行它时，文件没有被导入。

任何人都可以帮我查一下代码，代码是否适用于我的场景？

Sub From_XML_To_XL_02
On Error GoTo errh
Dim myWB As Workbook, WB As Workbook
Set myWB = ThisWorkbook
Dim myPath
  myPath = "C:\WorkFolder\Projects\"
Dim myFile
  myFile = Dir(myPath & "*.xml")
Dim t As Long, N As Long, r As Long, c As Long
  t = 1
  N = 0
Application.ScreenUpdating = False
Do While myFile <> ""
   N = N + 1
   Set WB = Workbooks.OpenXML(FileName:=myPath & myFile, LoadOption:=xlXmlLoadImportToList)
   If N > 1 Then
        r = WB.Sheets(1).Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        c = WB.Sheets(1).Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        WB.Sheets(1).Range(Cells(3, "A"), Cells(r, c)).Copy myWB.Sheets(1).Cells(t, "A")
   Else
      WB.Sheets(1).UsedRange.Copy myWB.Sheets(1).Cells(t, "A")
  End If
WB.Close False
t = myWB.Sheets(1).Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
myFile = Dir()
  Loop
Application.ScreenUpdating = True
  myWB.Save
Exit Sub
errh:
 MsgBox "no files xml"
End Sub

Answer 1

我对您的代码进行了一些更改，现在它可以正常工作并保存文件，例如File1.xls，File2.xls等。您的代码上已经标记了更改。仍然存在一个小问题，即保存的最后一个文件在工作区中保持打开状态。由于我的一些其他事情的预占，我无法进一步检查。我希望你能够解决这个问题。修改后的代码如下。

 Sub From_XML_To_XL_02
    On Error GoTo errh
    Dim myWB As Workbook, WB As Workbook
    Set myWB = ThisWorkbook
    Dim myPath
    myPath = "C:\WorkFolder\Projects\"
    Dim myFile
    myFile = Dir(myPath & "*.xml")
    Dim t As Long, N As Long, r As Long, c As Long
    t = 1
    N = 0
    Application.ScreenUpdating = False
    Do While Len(myFile) > 0             'Do While myFile <> ""
     N = N + 1
      Set WB = Workbooks.OpenXML(ThisWorkbook.Path & "\" & myFile)   ' Set WB = Workbooks.OpenXML(FileName:=myPath & myFile, LoadOption:=xlXmlLoadImportToList)
       If N > 1 Then
        r = WB.Sheets(1).Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        c = WB.Sheets(1).Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        WB.Sheets(1).Range(Cells(3, "A"), Cells(r, c)).Copy myWB.Sheets(1).Cells(t, "A")
        Else
        WB.Sheets(1).UsedRange.Copy myWB.Sheets(1).Cells(t, "A")
      End If
                                     'WB.Close False
      t = myWB.Sheets(1).Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    myWB.SaveAs Filename:="C:\WorkFolder\Projects\Files" & N & ".xls" 'added save path here to save in different files
    WB.Close False
    myFile = Dir()
    Loop
    Application.ScreenUpdating = True
    myWB.Save
Exit Sub
 errh:
 MsgBox "no files xml"
 End Sub

将.xml导入Excel

1 个答案: