Мне нужна помощь, чтобы расширить код VBA до неопределенного диапазона

Question

У меня есть большое количество XML-файлов, которые случайно названы в одной большой папке.

В приведенном ниже коде выполняется поиск конкретных XML-файлов путем поиска поля в файле XML и сравнения его с диапазоном влист Excel.

Затем он копирует соответствующие XML-файлы в новую папку и переименовывает их для удобства чтения.

Все работает нормально, за исключением очень медленного. У меня проблема в том, что это очень маленький диапазон, на который он смотрит. Я хотел бы, чтобы он был расширен на весь столбец C из строки 3, если в ячейках есть данные.

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