Em cần tổng hợp dữ liệu từ nhiều file excel vào 1 file. Mò trên diễn đàn thì em đã copy được 1 đoạn code làm được gần đúng yêu cầu.
Còn một chỗ em chưa làm được:
-Copy ô A1 (file cửa hàng 1) & ô A1 (file cửa hàng 2) vào trong các ô của cột A (file Test). Để nhìn sẽ biết nhân viên nào thuộc cửa hàng nào
Do tay ngang nên em cũng chưa hiểu hết các đoạn code. Nhờ anh chị giúp đỡ ạ.
----------------------------------------------------------------------------------------
Code:
Function GetConnXLS(ByVal cFileName As String, _
Optional ByVal InformErrMSG As Boolean = False)
On Error GoTo errHandling:
'Open ADO connection to excel workbook
Dim oConn As Object
Dim Ext As String, ConnStr As String
Set oConn = CreateObject("ADODB.Connection")
ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & cFileName & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes;"";"
oConn.Open ConnStr
Set GetConnXLS = oConn
errHandling:
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
SheetName = "Sheet1" & "$" 'Sheet can lay du lieu
RangeAddress = "A2:B1000" 'Vung du lieu can
Dim files As Variant 'Gan bien files la kieu du lieu linh dong
files = Application.GetOpenFilename(, , , , True) 'Mo ra hop thoai de chon file
If VarType(files) = vbBoolean Then Exit Sub
Set sh = Sheets("Master") 'Sheet gan du lieu
For k = LBound(files) To UBound(files)
Set cnn = GetConnXLS(files(k))
If cnn Is Nothing Then
MsgBox "Check lai co so du lieu file: " & files(k)
Exit Sub
End If
Set rst = cnn.Execute("SELECT *,""" & files(k) & """ as [From File] FROM [" & SheetName & RangeAddress & "]") 'Bien rst se co moi tinh chat du lieu trong range & sheet da copy
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
I = I + sh.Range("A" & 4 + I).CopyFromRecordset(rst)
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing
Next k
MsgBox "Done"
End Sub
Còn một chỗ em chưa làm được:
-Copy ô A1 (file cửa hàng 1) & ô A1 (file cửa hàng 2) vào trong các ô của cột A (file Test). Để nhìn sẽ biết nhân viên nào thuộc cửa hàng nào
Do tay ngang nên em cũng chưa hiểu hết các đoạn code. Nhờ anh chị giúp đỡ ạ.
----------------------------------------------------------------------------------------
Code:
Function GetConnXLS(ByVal cFileName As String, _
Optional ByVal InformErrMSG As Boolean = False)
On Error GoTo errHandling:
'Open ADO connection to excel workbook
Dim oConn As Object
Dim Ext As String, ConnStr As String
Set oConn = CreateObject("ADODB.Connection")
ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & cFileName & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes;"";"
oConn.Open ConnStr
Set GetConnXLS = oConn
errHandling:
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
SheetName = "Sheet1" & "$" 'Sheet can lay du lieu
RangeAddress = "A2:B1000" 'Vung du lieu can
Dim files As Variant 'Gan bien files la kieu du lieu linh dong
files = Application.GetOpenFilename(, , , , True) 'Mo ra hop thoai de chon file
If VarType(files) = vbBoolean Then Exit Sub
Set sh = Sheets("Master") 'Sheet gan du lieu
For k = LBound(files) To UBound(files)
Set cnn = GetConnXLS(files(k))
If cnn Is Nothing Then
MsgBox "Check lai co so du lieu file: " & files(k)
Exit Sub
End If
Set rst = cnn.Execute("SELECT *,""" & files(k) & """ as [From File] FROM [" & SheetName & RangeAddress & "]") 'Bien rst se co moi tinh chat du lieu trong range & sheet da copy
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
I = I + sh.Range("A" & 4 + I).CopyFromRecordset(rst)
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing
Next k
MsgBox "Done"
End Sub
