Sub ImportXML()
Dim appAccess As Object
Dim fpath As String
Dim filesys, filetxt, getname, path
Dim ImpOK As Boolean
'Dim f As StringConst acAppendData = 2

Set objAccess = CreateObject("Access.Application")
objAccess.OpenCurrentDatabase ("c:\test1.mdb")

fpath = "C:\New"

Dim fso, f, f1, fc, s
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set f = fso.GetFolder(fpath)
    Set fc = f.Files
   For Each f1 In fc
    'Debug.Print f1
    If Right(f1, 4) = ".xml" Then
     ' MsgBox f1.Name
        ImpOK = True
     On Error GoTo test:
    
        objAccess.ImportXML DataSource:=f1.path, ImportOptions:=acStructureAndData
        '   objAccess.ImportXML DataSource:=f1.path, ImportOptions:=acAppendData
           DoEvents
        DoCmd.SetWarnings False
        DoCmd.RunSQL "Insert into ImportResults values('OK','" & f1.Name & "','" & Now() & "','" & f1.path & "' );"
        DoCmd.SetWarnings True
        If ImpOK = True Then
            fso.CopyFile f1.path, fpath & "\successfulimport\" & f1.Name
         End If

aftererror:
    End If
       
   Next
   ShowFileList = s


objAccess.CloseCurrentDatabase
'appAccess.Quit acExit
Set objAccess = Nothing
Exit Sub
test:
DoCmd.SetWarnings False
DoCmd.RunSQL "Insert into ImportResults values('ERROR','" & f1.Name & "','" & Now() & "','" & f1.path & "' );"
ImpOK = False

DoCmd.SetWarnings True
Resume aftererror:
End Sub

Sub DeleteTableContents()
CurrentDb.Execute "Delete * from ", dbFailOnError
DoCmd.RunSQL "Delete * from "
DoEvents

End Sub


 Sub deletesheets()
Dim i As Integer
Dim isht As Integer
 On Error GoTo ErrHandler
  Application.DisplayAlerts = False
    ThisWorkbook.Sheets.Add
        ActiveSheet.Name = "Placeholder"
    isht = ThisWorkbook.Sheets.Count
    Do While ThisWorkbook.Sheets.Count > 1
    Debug.Print Sheets(1).Name
        If Sheets(1).Name <> "Placeholder" Then
            Sheets(1).Delete
           Else
            Sheets(2).Delete
        End If
      'i = i + 1
    Loop
    Exit Sub
  Application.DisplayAlerts = True
ErrHandler:
Resume Next

 
End Sub


Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
    Dim ary As Variant
    Dim shtname As String
    Dim aryshtname() As Variant
    Dim crntcnt As Integer
   
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
      MultiSelect:=True, Title:="Files to Merge")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    While x <= UBound(FilesToOpen)
        ary = Split(FilesToOpen(x), "\")
       
        Workbooks.Open Filename:=FilesToOpen(x)
       
        shtname = Left(Right(ary(UBound(ary)), 14), 10)
       
        'creating ary
        'For i = 1 To Workbooks(ary(UBound(ary))).Sheets.Count
         '   aryshtname(i) = Workbooks(ary(UBound(ary))).Sheet(i).Name
        'Next i
            'Sheets(i).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            crntcnt = ThisWorkbook.Sheets.Count
            Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            For i = crntcnt + 1 To ThisWorkbook.Sheets.Count
                ThisWorkbook.Sheets(i).Name = shtname + " " + ThisWorkbook.Sheets(i).Name
            Next i
         
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
Select Case Err.Number
Case 1004
    Debug.Print " " + ThisWorkbook.Sheets(i).Name + "1"
    ThisWorkbook.Sheets(i).Name = shtname + " " + ThisWorkbook.Sheets(i).Name + "1"
    Resume Next
Case Else
    MsgBox Err.Description
    Resume ExitHandler
End Select
End Sub

 


Sub Combine()
    Dim J As Integer

    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add ' add a sheet in first place
    Sheets(1).Name = "Combined"

    ' copy headings
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")

    ' work through sheets
    For J = 2 To Sheets.Count ' from sheet 2 to last sheet
        Sheets(J).Activate ' make the sheet active
        Range("A1").Select
        Selection.CurrentRegion.Select ' select all cells in this sheets

        ' select all lines except title
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select

        ' copy cells selected in the new sheet on last line
        Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
    Next
End Sub

 

 Sub deletesheets()
Dim i As Integer
Dim isht As Integer
Dim sShtName As String
'Delete sheets which are not like a certain name

sShtName = "Explain By Book"

 On Error GoTo ErrHandler
 
  Application.DisplayAlerts = False
    isht = ThisWorkbook.Sheets.Count
    i = 1
    For i = i To isht
'    Debug.Print Sheets(i).Name
        If InStr(Sheets(i).Name, sShtName) < 1 Then
            Debug.Print "DEL:" & Sheets(i).Name
            Sheets(i).Delete
           
        End If
      'i = i + 1
    Next i
    Exit Sub
  Application.DisplayAlerts = True
 
 
 
 Exit Sub
 
 'OLD CODE
  Application.DisplayAlerts = False
    ThisWorkbook.Sheets.Add
        ActiveSheet.Name = "Placeholder"
    isht = ThisWorkbook.Sheets.Count
    Do While ThisWorkbook.Sheets.Count > 1
    Debug.Print Sheets(1).Name
        If InStr(Sheets(1).Name, sShtName) < 1 Then
            Sheets(1).Delete
           Else
            Sheets(2).Delete
        End If
      'i = i + 1
    Loop
    Exit Sub
  Application.DisplayAlerts = True
ErrHandler:
Resume Next

 
End Sub


Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
    Dim ary As Variant
    Dim shtname As String
    Dim aryshtname() As Variant
    Dim crntcnt As Integer
   
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
      MultiSelect:=True, Title:="Files to Merge")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    While x <= UBound(FilesToOpen)
        ary = Split(FilesToOpen(x), "\")
       
        Workbooks.Open Filename:=FilesToOpen(x)
       
        shtname = Left(Right(ary(UBound(ary)), 14), 10)
       
        'creating ary
        'For i = 1 To Workbooks(ary(UBound(ary))).Sheets.Count
         '   aryshtname(i) = Workbooks(ary(UBound(ary))).Sheet(i).Name
        'Next i
            'Sheets(i).Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            crntcnt = ThisWorkbook.Sheets.Count
            Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            For i = crntcnt + 1 To ThisWorkbook.Sheets.Count
                ThisWorkbook.Sheets(i).Name = shtname + " " + ThisWorkbook.Sheets(i).Name
            Next i
         
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
Select Case Err.Number
Case 1004
    Debug.Print " " + ThisWorkbook.Sheets(i).Name + "1"
    ThisWorkbook.Sheets(i).Name = shtname + " " + ThisWorkbook.Sheets(i).Name + "1"
    Resume Next
Case Else
    MsgBox Err.Description
    Resume ExitHandler
End Select
End Sub

 


Sub Combine()
    Dim J As Integer

    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add ' add a sheet in first place
    Sheets(1).Name = "Combined"

    ' copy headings
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")

    ' work through sheets
    For J = 2 To Sheets.Count ' from sheet 2 to last sheet
        Sheets(J).Activate ' make the sheet active
        Range("A1").Select
        Selection.CurrentRegion.Select ' select all cells in this sheets

        ' select all lines except title
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select

        ' copy cells selected in the new sheet on last line
        Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
    Next
End Sub

 

Sub ImportXML()
'
' ImportXML Macro
'
Dim sFile As String
Dim sPath As String
Dim i As Integer
Dim iFileCount As Integer

Dim x As Integer
Dim ary As Variant
Dim shtname As String
Dim aryshtname() As Variant
Dim crntcnt As Integer
   
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False


'Setting Paths
sPathsource = "H:\dheal\\new\unzipped\"
sPathdest = "H:\dheal\\tests\"

'default the path to browse
' and select files need
ChDir sPathsource
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="XML, *.xml", _
      MultiSelect:=True, Title:="Files to Convert -" & sPathsource)

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

'Using selected files create an array to loop through
    x = 1
    While x <= UBound(FilesToOpen)
        ary = Split(FilesToOpen(x), "\")
        sFile = ary(UBound(ary))

                'Saving the file from xml to csv
                    Workbooks.OpenXML Filename:=sPathsource + sFile, LoadOption:=xlXmlLoadImportToList
                    Columns("A:A").Select
                    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                    Range("A1").Select
                    ActiveCell.FormulaR1C1 = "Type"
                    Range("A2").Select
                    ActiveCell.FormulaR1C1 = "new"
                    Columns("A:A").Select
                    Range("A1").Activate
                    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
                   
                    ActiveCell.FormulaR1C1 = "Source"
                    Range("A2").Select
                    ActiveCell.FormulaR1C1 = sFile
                   
                    Columns("A:B").Select
                    Range("A2:B10001").Select
                    Selection.FillDown
                   
                    ActiveWorkbook.SaveAs Filename:=sPathdest & "\" & Replace(sFile, ".xml", ".csv"), FileFormat:=xlCSV, CreateBackup:=False
                
                    ActiveWorkbook.Close (True)
                            x = x + 1
      
    Wend
   
   
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
Select Case Err.Number
Case 1004
    Debug.Print " " + ThisWorkbook.Sheets(i).Name + "1"
    ThisWorkbook.Sheets(i).Name = shtname + " " + ThisWorkbook.Sheets(i).Name + "1"
    Resume Next
Case Else
    MsgBox Err.Description
    Resume ExitHandler
End Select
 
End Sub