Birden fazla XML dosyasını import etme

[MUHALKO]

Değerli Forum Üyeleri,

Sizlere hayırlı günler diliyorum.

Birden fazla XML dosyasını aktif sayfaya import eden bir kod buldum. Kodu paylaşan arkadaşımın/büyüğümün affına sığınarak kodu buradan paylaşıyorum.

Kod: Tümünü seç

Sub xlTR_192851_çok_sayıda_xml_dosyayı_aktif_sayfaya_import_etme()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next

Dim xmlKlasor As String, xmlDosyalar As String, xmlDosya As String
With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        If .Show = -1 Then xmlKlasor = .SelectedItems(1) & "\" Else Exit Sub 'klasör seçilmez ise uyarı vermeden makroyu sona erdirir
End With

xmlDosyalar = Dir(xmlKlasor & "*xml")
Do While xmlDosyalar <> ""
        xmlDosya = xmlKlasor & xmlDosyalar
        ActiveWorkbook.XmlImport Url:=xmlDosya, ImportMap:=Nothing, Overwrite:=True, Destination:=ActiveCell
        
       Selection.End(xlDown).Offset(1).Select 'xml dosyaları başlıkları ile, alt alta bitişik import eder
       ' Selection.End(xlDown).Offset(2).Select 'xml dosyaları başlıkları ile, alt alta arada 1 boş satır bırakarak import eder
        xmlDosyalar = Dir()
Loop
Cells.WrapText = False


End Sub

Kodu çalıştırdığımda ilk XML dosyası import edip, ikincisine başlarken "XML tablosu farklı bir XML eşlmesine bağlı olduğundan işlem tamamlanamıyor" hatası veriyor ve işlem sonlanıyor. Kodun başına "On Error Resume Next" yazıp çalıştırdığımda ise hedef klasördeki dosyaları bir atlayarak içeriye alıyor. Klasörde 100 dosya varsa bir atlayarak import ediyor. 50 adet XML dosyası import edilmiş oluyor.

Nerede yanlış yapıyor olabilirim? Ya da birden fazla XML dosyasını import edebileceğim farklı bir kod var mıdır? Konuyu baya bir araştırdım ama VBA-XML yeni öğrenmeye başladığım bir konu. Yardımlarınız için şimdiden teşekkür ederim.

[MUHALKO]

Değerli forum üyeleri, birden fazla dosyayı XML dosyasını impor etme ile ilgili olarak biraz yabancı sitelerden birazda VBA forum sitelerindeki kodlardan harmanlayarak çözdüm. Belki başka bir arkadaşa lazım olur diye kodu paylaşıyorum.

Kod: Tümünü seç

Sub DAT_BAS()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next

Sheets("DATABASE").Delete
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "DATABASE"
   
Dim myWB As Workbook, WB As Workbook
Set myWB = ThisWorkbook
Dim myPath
myPath = UserForm1.TextBox5.Text
Dim myFile
myFile = Dir(myPath & "*.xml")
Dim t As Long, N As Long, r As Long, c As Long
t = 1
N = 0
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(1, "A"), Cells(r, c)).Copy myWB.Sheets("DATABASE").Cells(t, "A")
Else
WB.Sheets(1).UsedRange.Copy myWB.Sheets("DATABASE").Cells(t, "A")
End If
WB.Close False
t = myWB.Sheets("DATABASE").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
myFile = Dir()
Loop
myWB.Save
Exit Sub

End Sub

XML şemaları aynı ise tam istendiği gibi sıralıyor. Şemalar farklı ise manuel düzeltme gerekecek.
Umarım faydalı olur.

[Tarkan VURAL]

Elinize sağlık