Function GetConnXLS(ByVal cFileName As String, _
Optional ByVal InformErrMSG As Boolean = False) As ADODB.Connection
Dim oConn As ADODB.Connection
Dim Ext As String, ConnStr As String
Set oConn = New ADODB.Connection
ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & cFileName & ";" & _
"Extended Properties=""Excel 12.0 xml;HDR=Yes"";"
oConn.Open ConnStr
Set GetConnXLS = oConn
Exit Function
LOI:
If Err.Number <> 0 Then
Set oConn = Nothing
If InformErrMSG Then
MsgBox "GetConnXLS" & ": " & Err.Number & " " & Err.Description, vbCritical
End If
End If
End Function
Sub Merge_All()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sh As Worksheet
Dim I As Long, k As Long, CountFiles As Long, J As Long, strData, _
kDS As Long, xKorr As Integer
files = Application.GetOpenFilename(, , , , True)
If VarType(files) = vbBoolean Then Exit Sub
Set sh = Sheets("Master")
For k = LBound(files) To UBound(files)
kDS = lastRowClosedFile(files(k), "Master", "A:A")
Set cnn = GetConnXLS(files(k))
If cnn Is Nothing Then
MsgBox "Check lai co so du lieu file: " & files(k)
Exit Sub
End If
strData = "SELECT * From [Tabelle1$A5:AN" & kDS & "];"
Set rst = cnn.Execute(strData)
CountFiles = CountFiles + 1
If CountFiles = 1 Then
For J = 0 To rst.Fields.Count - 1
sh.Cells(3, J + 1).Value = rst.Fields(J).Name
Next J
End If
If k = 1 Then
xKorr = 1
Else
xKorr = 0
End If
sh.Range("I" & 4 + I - xKorr).Value = files(k)
I = I + sh.Range("A" & 4 + I).CopyFromRecordset(rst)
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing
Next k
MsgBox "Done", vbSystemModal + 48, "Hurraaa..."
End Sub
Function lastRowClosedFile(ByVal FileName As String, SheetName As String, TargetRange As String) As Long
Dim objADO As Object
On Error Resume Next
Set objADO = ExcelTable(FileName, SheetName, TargetRange)
lastRowClosedFile = objADO.RecordCount + 1
objADO.Close
End Function
Private Function ExcelTable(ByRef Path As String, ByRef Table As String, ByRef SourceRange As String) As Object
Dim SQL As String
Dim Con As String
SQL = "select * from [" & Table & "$" & SourceRange & "]"
If Mid(Path, InStrRev(Path, ".") + 1) = "xls" Then
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & Path & ";"
ElseIf Mid(Path, InStrRev(Path, ".") + 1) Like "xls?" Then
Con = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Extended Properties=""Excel 12.0;HDR=YES"";" _
& "Data Source=" & Path & ";"
Else
Exit Function
End If
Set ExcelTable = CreateObject("ADODB.Recordset")
ExcelTable.Open SQL, Con, 3, 1
End Function