将范围扩展到未定义的范围

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