mar19.xlsx, Apr19.xlsx must be in one folder
MainDatabase should not be in the same folder above.
Verify the value, some are different from yours.
Option Explicit
Sub test()
Dim myDir As String, fn As String, txt As String, ws As Worksheet
Dim cn As Object, rs As Object, dic As Object, RegX As Object, x() As String, n As Long
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
fn = Dir(myDir & "*.xls")
If fn = "" Then Exit Sub
Set ws = Sheets("sheet1")
ws.Cells.ClearContents
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1: ReDim x(1 To 1000)
Set RegX = CreateObject("VBScript.RegExp")
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;HDR=No;"
.Open myDir & fn
End With
Do While fn <> ""
n = n + 1: x(n) = Application.Replace(Left$(fn, InStrRev(fn, ".") - 1), 4, , "-")
rs.Open "Select * From `Sheet1$` In '" & myDir & fn & "' 'Excel 12.0;''HDR=No;''';", cn
txt = rs.GetString(2, , Chr(2), vbCrLf)
rs.Close
Get_Details txt, dic, RegX, x(n)
fn = Dir
Loop
Set rs = Nothing: Set cn = Nothing
ReDim Preserve x(1 To n)
OutPut dic, ws, x
End Sub
Private Sub Get_Details(txt As String, dic As Object, RegX As Object, fn As String)
Dim mtch As Object, m As Object, myCountry As String, sm As Object
With RegX
.Global = True
.MultiLine = True
.Pattern = "^\u0002{2}\d+\)(.+?)\u0002+\r\n(.+\r\n)+?(?=(^\u0002{2}\d+\)|$))|" & _
"^\u0002([^\u0002]+)\u0002+\r\n(.+\r\n)+?(?=(^\u0002[^\u0002]+\u0002+\r\n|$))"
For Each m In .Execute(txt)
myCountry = m.submatches(0) & m.submatches(3)
If Not dic.exists(myCountry) Then Set dic(myCountry) = CreateObject("Scripting.Dictionary")
.Pattern = "^\u0002+([^\u0002]+)\u0002(Low|None)\u0002.+\u0002(\d+(\.\d+)?)$"
For Each sm In .Execute(m)
If Not dic(myCountry).exists(sm.submatches(0)) Then
Set dic(myCountry)(sm.submatches(0)) = CreateObject("Scripting.Dictionary")
End If
dic(myCountry)(sm.submatches(0))(fn) = sm.submatches(2)
Next
Next
End With
End Sub
Private Sub OutPut(dic As Object, ws As Worksheet, x)
Dim e, n As Long, i As Long, ii As Long
Application.ScreenUpdating = False
For Each e In dic
n = n + 1: ws.Cells(n, 1) = e: ws.Cells(n, 2).Resize(, UBound(x)) = x: n = n + 1
ws.Cells(n, 1).Resize(dic(e).Count).Value = Application.Transpose(dic(e).keys)
For i = n To n + dic(e).Count - 1
For ii = 1 To UBound(x)
ws.Cells(i, ii + 1) = dic(e)(ws.Cells(i, 1).Value)(ws.Cells(n - 1, ii + 1).Value)
Next
Next
n = n + dic(e).Count
Next
Application.ScreenUpdating = True
End Sub
Bookmarks