मेरे पास एक फ़ोल्डर में बड़ी संख्या में 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
0
Gjeep 3 नवम्बर 2019, 18:26

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
GWD 4 नवम्बर 2019, 10:04