Question

我在一个文件夹中有大量的xml文件。

以下代码通过搜索XML文件中的字段并将其与Excel工作表中的范围进行比较来查找特定的xml文件。

然后将匹配的xml文件复制到新文件夹，并重命名它们以提高可读性。

一切正常，但速度很慢。

它看起来很小。如果单元格中有数据，我想将范围扩展到数据透视表，其值从F4开始向下。

Global so1, so2, so3, so4, so5, so6, so7, so8, so9, so10, so11, so12, so13, so14, so15, so16, so17, so18 As String
Global Myfile As String
Global WholeOrderNumber As String
Global NewFile As String
Global Myfiletemp As String
Global FileName As String
Global TempFolder As String
Global OrderNumber As String
Global TempOrdernumber As String
Global TempMonth As String
Global Month As String

Sub Find_Delivery_XML()
'******************************************************************
'loop trough folder
'and locate ordre numbers in XML Files in range "C4" to "C21"
'if found then call loadXML and copyit to copy the files
'******************************************************************
 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = True

Worksheets("Main").Select ' pick Main sheet
so1 = Range("C4")
so2 = Range("C5")
so3 = Range("C6")
so4 = Range("C7")
so5 = Range("C8")
so6 = Range("C9")
so7 = Range("C10")
so8 = Range("C11")
so9 = Range("C12")
so10 = Range("C13")
so11 = Range("C14")
so12 = Range("C15")
so13 = Range("C16")
so14 = Range("C17")
so15 = Range("C18")
so16 = Range("C19")
so17 = Range("C20")
so18 = Range("C21")

'In Case of Cancel
NextCode:

  TempFolder = "C:\xml_found\"
  myPath = "C:\xml_all\"
  myExtension = "DK2W_PJ_SO_*.xml*"
  Myfile = Dir(myPath & myExtension)

'Loop through each file in folder
  Do While Myfile <> ""
  Myfiletemp = "C:\xml_all\" & Myfile

loadXML

If s18 = OrderNumber Then
  copyit
End If
If so17 = OrderNumber Then
  copyit
End If
If so16 = OrderNumber Then
  copyit
End If
If so15 = OrderNumber Then
  copyit
End If
If so14 = OrderNumber Then
  copyit
End If
If so13 = OrderNumber Then
  copyit
End If
If so12 = OrderNumber Then
  copyit
End If
If so11 = OrderNumber Then
  copyit
End If
If so10 = OrderNumber Then
  copyit
End If
If so9 = OrderNumber Then
  copyit
End If
If so8 = OrderNumber Then
  copyit
End If
If so7 = OrderNumber Then
  copyit
End If
If so6 = OrderNumber Then
  copyit
End If
If so5 = OrderNumber Then
  copyit
End If
  If so4 = OrderNumber Then
copyit
End If
If so3 = OrderNumber Then
  copyit
End If
If so2 = OrderNumber Then
  copyit
End If
If so1 = OrderNumber Then
  copyit
End If

DoEvents

Myfile = Dir

  Loop

  MsgBox "Done"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub


Sub loadXML()
'******************************************************************
'load XML files and get ordernumber from XML files
' located in = xobject.ChildNodes.Item(1).Text
'******************************************************************

Dim strPath As String
Dim XDoc As Object
Set XDoc = CreateObject("MSXML2.DOMDocument")
XDoc.async = False
XDoc.validateOnParse = False
XDoc.Load (Myfiletemp)
Set xObjDetails = XDoc.ChildNodes(0)
Set xobject = xObjDetails.FirstChild
TempOrdernumber = xobject.ChildNodes.Item(1).Text
TempMonth = xobject.ChildNodes.Item(2).Text
OrderNumber = Mid(TempOrdernumber, 8, 7)
WholeOrderNumber = TempOrdernumber
Month = Mid(TempMonth, 4, 2)
NewFile = WholeOrderNumber & "_" & Mid(Myfiletemp, 24, 27)

End Sub


Sub copyit()
'******************************************************************
'copy files to DIR "C2" and rename them to the new filename "NewFile"
'NewFile = WholeOrderNumber + "_" + last 27 characters of Myfiletemp
'******************************************************************
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Call oFSO.CopyFile(Myfiletemp, TempFolder & Range("C2") & "\" & NewFile, True)

End Sub

Answer 1

也许这行得通，我只是将代码的重复部分放入循环中...

Global so() As String
Global Myfile As String
Global WholeOrderNumber As String
Global NewFile As String
Global Myfiletemp As String
Global FileName As String
Global TempFolder As String
Global OrderNumber As String
Global TempOrdernumber As String
Global TempMonth As String
Global Month As String

    Sub Find_Delivery_XML()
Dim lastRow As long
Dim firstRow As long
Dim i as long
Dim col as long
'******************************************************************
'loop trough folder
'and locate ordre numbers in XML Files in column C
'if found then call loadXML and copyit to copy the files
'******************************************************************
 Application.EnableEvents = True
 Application.Calculation = xlCalculationAutomatic
 Application.ScreenUpdating = True

Worksheets("Main").Select ' pick Main sheet

firstRow = 4 '<----first row of data here, i put it to 4 because in your example it starts at C4
i = firstRow
col = 6 'Set Column Number here. Since F is number 6 in the Alphabet thats the default i set it to now
With Application.Worksheets("Main")
    Do Until .Cells(i, col) = "" and i > firstRow
        i = i + 1
    Loop
    lastRow = i - 1
    ReDim so(lastRow)

    For i = firstRow To lastRow
        so(i) = .Cells(i, col)
    Next i
End With


'In Case of Cancel
NextCode:

  TempFolder = "C:\xml_found\"
  myPath = "C:\xml_all\"
  myExtension = "DK2W_PJ_SO_*.xml*"
  Myfile = Dir(myPath & myExtension)

'Loop through each file in folder
  Do While Myfile <> ""
  Myfiletemp = "C:\xml_all\" & Myfile

loadXML


For i = firstRow To lastRow
    If so(i) = OrderNumber Then
      copyit
    End If
Next i


DoEvents

Myfile = Dir

  Loop

  MsgBox "Done"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Sub loadXML()
'******************************************************************
'load XML files and get ordernumber from XML files
' located in = xobject.ChildNodes.Item(1).Text
'******************************************************************

Dim strPath As String
Dim XDoc As Object
Set XDoc = CreateObject("MSXML2.DOMDocument")
XDoc.async = False
XDoc.validateOnParse = False
XDoc.Load (Myfiletemp)
Set xObjDetails = XDoc.ChildNodes(0)
Set xobject = xObjDetails.FirstChild
TempOrdernumber = xobject.ChildNodes.Item(1).Text
TempMonth = xobject.ChildNodes.Item(2).Text
OrderNumber = Mid(TempOrdernumber, 8, 7)
WholeOrderNumber = TempOrdernumber
Month = Mid(TempMonth, 4, 2)
NewFile = WholeOrderNumber & "_" & Mid(Myfiletemp, 24, 27)



End Sub

Sub copyit()
'******************************************************************
'copy files to DIR "C2" and rename them to the new filename "NewFile"
'NewFile = WholeOrderNumber + "_" + last 27 characters of Myfiletemp
'******************************************************************
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Call oFSO.CopyFile(Myfiletemp, TempFolder & Range("C2") & "\" & NewFile, True)

End Sub

将范围扩大到不确定范围

1 个答案: