Hoàng Nhật Phương
Thành viên gắn bó



- Tham gia
- 5/11/15
- Bài viết
- 1,895
- Được thích
- 1,219
Bạn thử dùng code sau xem đúng chưa nhé!Xin chào tất cả các bạn,
Như tiêu Oanh Thơ đã nêu,vấn đề chi tiết xin được nêu cụ thể trong tập tin.
Nhờ các bạn giúp đỡ cho tôi trường hợp trong tập tin gửi kèm ạ.
Sub SummaryData()
Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String
Dim sArr(), dArr(1 To 10000, 1 To 6)
Dim I As Long, K As Long, lC As Long
Sheet1.Range("B7:G65000").ClearContents
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Filters.Add "Microsoft Excel Files", "*.xls*", 1
If Not .Show = -1 Then
MsgBox "Ban chua chon file", vbCritical, "GPE"
Exit Sub
End If
Application.DisplayAlerts = False
For Each Item In .SelectedItems
Set Wk = Workbooks.Open(Item)
For Each Ws In Wk.Sheets
With Ws
WsName = .Name
.Columns("A:G").Delete: .Rows("8:9").Delete
lC = .Range("A7").End(xlToRight).Column
sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value
For I = 2 To UBound(sArr, 2)
K = K + 1
dArr(K, 1) = WsName: dArr(K, 3) = sArr(1, I)
dArr(K, 5) = sArr(2, I): dArr(K, 6) = sArr(3, I)
Next I
End With
Next Ws
Wk.Close False
Next Item
Application.DisplayAlerts = False
End With
Sheet1.Range("B7").Resize(K, 6) = dArr
MsgBox "Done", vbInformation, "GPE"
End Sub
Bạn thử dùng code sau xem đúng chưa nhé!
Mã:Sub SummaryData() Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String Dim sArr(), dArr(1 To 10000, 1 To 6) Dim I As Long, K As Long, lC As Long Sheet1.Range("B7:G65000").ClearContents With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .Filters.Add "Microsoft Excel Files", "*.xls*", 1 If Not .Show = -1 Then MsgBox "Ban chua chon file", vbCritical, "GPE" Exit Sub End If Application.DisplayAlerts = False For Each Item In .SelectedItems Set Wk = Workbooks.Open(Item) For Each Ws In Wk.Sheets With Ws WsName = .Name .Columns("A:G").Delete: .Rows("8:9").Delete lC = .Range("A7").End(xlToRight).Column sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value For I = 2 To UBound(sArr, 2) K = K + 1 dArr(K, 1) = WsName: dArr(K, 3) = sArr(1, I) dArr(K, 5) = sArr(2, I): dArr(K, 6) = sArr(3, I) Next I End With Next Ws Wk.Close False Next Item Application.DisplayAlerts = False End With Sheet1.Range("B7").Resize(K, 6) = dArr MsgBox "Done", vbInformation, "GPE" End Sub
Bạn thử dùng code sau xem đúng chưa nhé!
Mã:Sub SummaryData() Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String Dim sArr(), dArr(1 To 10000, 1 To 6) Dim I As Long, K As Long, lC As Long Sheet1.Range("B7:G65000").ClearContents With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .Filters.Add "Microsoft Excel Files", "*.xls*", 1 If Not .Show = -1 Then MsgBox "Ban chua chon file", vbCritical, "GPE" Exit Sub End If Application.DisplayAlerts = False For Each Item In .SelectedItems Set Wk = Workbooks.Open(Item) For Each Ws In Wk.Sheets With Ws WsName = .Name .Columns("A:G").Delete: .Rows("8:9").Delete lC = .Range("A7").End(xlToRight).Column sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value For I = 2 To UBound(sArr, 2) K = K + 1 dArr(K, 1) = WsName: dArr(K, 3) = sArr(1, I) dArr(K, 5) = sArr(2, I): dArr(K, 6) = sArr(3, I) Next I End With Next Ws Wk.Close False Next Item Application.DisplayAlerts = False End With Sheet1.Range("B7").Resize(K, 6) = dArr MsgBox "Done", vbInformation, "GPE" End Sub
Bạn cho mình hỏi:Xin chào vanthinh3101,
Sau khi áp dụng vào thực tế có một vấn đề sau nhờ vanthinh3101 và các bạn xem giúp.
Ở file minh họa Oanh Thơ chỉ để những sheet cần lấy dữ liệu còn ở file thực tế còn có nhiều sheet khác nữa
Thành thật xin lỗi vanthinh3101 và các bạn rất nhiều về vấn đề này.
Để xác định được các tập tin cần lấy dữ liệu và các sheet cần lấy dữ liệu trong tập tin Oanh Thơ đã tạo thêm 1 sheet"Nguon" mong muốn code dựa vào các thông tin (tên file tên sheet) để lấy dữ liệu trong thư mục T8 ạ.
Oanh Thơ xin được gửi lại dữ liệu minh họa,nhờ vanthinh3101 và các bạn giúp đỡ ạ.
Bạn cho mình hỏi:
- Có khoảng bao nhiêu file cần tổng hợp.
- Ngoài các sheet cần tổng hợp, các sheet còn lại đều có tên là sheet1, sheet2, sheet... hay tên khác.
Bạn thử code này.Xin chào vanthinh3101,
Sau khi áp dụng vào thực tế có một vấn đề sau nhờ vanthinh3101 và các bạn xem giúp.
Ở file minh họa Oanh Thơ chỉ để những sheet cần lấy dữ liệu còn ở file thực tế còn có nhiều sheet khác nữa
Thành thật xin lỗi vanthinh3101 và các bạn rất nhiều về vấn đề này.
Để xác định được các tập tin cần lấy dữ liệu và các sheet cần lấy dữ liệu trong tập tin Oanh Thơ đã tạo thêm 1 sheet"Nguon" mong muốn code dựa vào các thông tin (tên file tên sheet) để lấy dữ liệu trong thư mục T8 ạ.
Oanh Thơ xin được gửi lại dữ liệu minh họa,nhờ vanthinh3101 và các bạn giúp đỡ ạ.
Const StartCll As String = "C3"
Const FirstRow As Long = 7
Const FirstCol As Long = 9
Sub CallMe()
Dim WriteToSh As Worksheet, TmpSh As Worksheet, sFileName As String, FileNameCll As Range, ShNameCll As Range
Dim sFolder As String
Application.ScreenUpdating = False
Set WriteToSh = ActiveSheet
Set TmpSh = AddTmpSh()
Set FileNameCll = Worksheets("Nguon").Range(StartCll)
sFolder = ThisWorkbook.Path & "\" & WriteToSh.Name
WriteToSh.Range("B" & FirstRow & ":G" & &H100000).ClearContents
Do Until FileNameCll.Value = ""
sFileName = FileNameCll.Value
If Len(Dir(sFolder & "\" & sFileName)) > 0 Then
Set ShNameCll = FileNameCll.Offset(, 1)
Do Until ShNameCll.Value = ""
If EnterFormula(TmpSh, sFolder, sFileName, ShNameCll.Value) Then _
WriteData TmpSh, WriteToSh, ShNameCll.Value
Set ShNameCll = ShNameCll.Offset(, 1)
Loop
End If
Set FileNameCll = FileNameCll.Offset(1)
Loop
DelTmpSh TmpSh
WriteToSh.Activate
Application.ScreenUpdating = True
End Sub
Private Sub WriteData(ByRef TmpSh As Worksheet, ByRef WriteToSh As Worksheet, ByVal CustomerName As String)
Dim NextRow As Long, ColsCount As Long
ColsCount = TmpSh.Cells(6, 1).Value - 1
If ColsCount = 0 Then Exit Sub
NextRow = WriteToSh.Cells(&H100000, 2).End(xlUp).Row + 1
If NextRow < FirstRow Then NextRow = FirstRow
With WriteToSh.Cells(NextRow, 2).Resize(ColsCount)
.Value = CustomerName
.Offset(, 2).Value = Application.WorksheetFunction.Transpose(TmpSh.Cells(1, FirstCol).Resize(, ColsCount))
.Offset(, 4).Resize(, 2).Value = Application.WorksheetFunction.Transpose(TmpSh.Cells(4, FirstCol).Resize(2, ColsCount))
End With
End Sub
Private Function AddTmpSh() As Worksheet
Set AddTmpSh = Worksheets.Add
AddTmpSh.Cells(6, 1).FormulaR1C1 = "=MATCH(0,R1C" & FirstCol & ":R1C[-1],0)"
End Function
Private Sub DelTmpSh(ByVal TmpSh As Worksheet)
Application.DisplayAlerts = False
TmpSh.Delete
Application.DisplayAlerts = True
End Sub
Private Function EnterFormula(ByRef TmpSh As Worksheet, ByVal sFolder As String, ByVal sFileName As String, ByVal sSheetName As String) As Boolean
On Error GoTo Err_
TmpSh.Rows("1:5").FormulaArray = "='" & sFolder & "\[" & sFileName & "]" & sSheetName & "'!7:11"
EnterFormula = True
Err_:
End Function
Bạn thử code này.
Lưu ý: Đứng ở sheet tên gì thì tổng hợp dữ liệu ở thư mục có tên đó; Thư mục chứa file cần tổng hợp và file chứa code này ở chung trong một thư mục mẹ.
PHP:Const StartCll As String = "C3" Const FirstRow As Long = 7 Const FirstCol As Long = 9 Sub CallMe() Dim WriteToSh As Worksheet, TmpSh As Worksheet, sFileName As String, FileNameCll As Range, ShNameCll As Range Dim sFolder As String Application.ScreenUpdating = False Set WriteToSh = ActiveSheet Set TmpSh = AddTmpSh() Set FileNameCll = Worksheets("Nguon").Range(StartCll) sFolder = ThisWorkbook.Path & "\" & WriteToSh.Name WriteToSh.Range("B" & FirstRow & ":G" & &H100000).ClearContents Do Until FileNameCll.Value = "" sFileName = FileNameCll.Value If Len(Dir(sFolder & "\" & sFileName)) > 0 Then Set ShNameCll = FileNameCll.Offset(, 1) Do Until ShNameCll.Value = "" If EnterFormula(TmpSh, sFolder, sFileName, ShNameCll.Value) Then _ WriteData TmpSh, WriteToSh, ShNameCll.Value Set ShNameCll = ShNameCll.Offset(, 1) Loop End If Set FileNameCll = FileNameCll.Offset(1) Loop DelTmpSh TmpSh WriteToSh.Activate Application.ScreenUpdating = True End Sub Private Sub WriteData(ByRef TmpSh As Worksheet, ByRef WriteToSh As Worksheet, ByVal CustomerName As String) Dim NextRow As Long, ColsCount As Long ColsCount = TmpSh.Cells(6, 1).Value - 1 If ColsCount = 0 Then Exit Sub NextRow = WriteToSh.Cells(&H100000, 2).End(xlUp).Row + 1 If NextRow < FirstRow Then NextRow = FirstRow With WriteToSh.Cells(NextRow, 2).Resize(ColsCount) .Value = CustomerName .Offset(, 2).Value = Application.WorksheetFunction.Transpose(TmpSh.Cells(1, FirstCol).Resize(, ColsCount)) .Offset(, 4).Resize(, 2).Value = Application.WorksheetFunction.Transpose(TmpSh.Cells(4, FirstCol).Resize(2, ColsCount)) End With End Sub Private Function AddTmpSh() As Worksheet Set AddTmpSh = Worksheets.Add AddTmpSh.Cells(6, 1).FormulaR1C1 = "=MATCH(0,R1C" & FirstCol & ":R1C[-1],0)" End Function Private Sub DelTmpSh(ByVal TmpSh As Worksheet) Application.DisplayAlerts = False TmpSh.Delete Application.DisplayAlerts = True End Sub Private Function EnterFormula(ByRef TmpSh As Worksheet, ByVal sFolder As String, ByVal sFileName As String, ByVal sSheetName As String) As Boolean On Error GoTo Err_ TmpSh.Rows("1:5").FormulaArray = "='" & sFolder & "\[" & sFileName & "]" & sSheetName & "'!7:11" EnterFormula = True Err_: End Function
Tôi cũng không biết.Xin chào huuthang_bd,
Oanh Thơ cảm ơn Anh rất nhiều,
Không hiểu nguyên nhân gì mà Oanh Thơ copy code của Anh vào cửa sổ code thì báo lỗi nhiều dòng đỏ và các từ khóa không hiển thị màu xanh, phiền Anh có thể gửi cho Oanh Thơ xin tập tin đính kèm được không ạ.
Tôi cũng không biết.
Đây là file đã có code.
Mình đã sửa lại code, bạn thử xem thế nào, có gì báo mình.Xin chào vanthinh3101,
Sau khi áp dụng vào thực tế có một vấn đề sau nhờ vanthinh3101 và các bạn xem giúp.
Ở file minh họa Oanh Thơ chỉ để những sheet cần lấy dữ liệu còn ở file thực tế còn có nhiều sheet khác nữa
Thành thật xin lỗi vanthinh3101 và các bạn rất nhiều về vấn đề này.
Để xác định được các tập tin cần lấy dữ liệu và các sheet cần lấy dữ liệu trong tập tin Oanh Thơ đã tạo thêm 1 sheet"Nguon" mong muốn code dựa vào các thông tin (tên file tên sheet) để lấy dữ liệu trong thư mục T8 ạ.
Oanh Thơ xin được gửi lại dữ liệu minh họa,nhờ vanthinh3101 và các bạn giúp đỡ ạ.
Sub SummaryData()
Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String
Dim Names(1 To 1000), Rng(), TestFile, TestSheet
Dim A As Long, B As Long, C As Long
Dim sArr(), dArr(1 To 10000, 1 To 6)
Dim i As Long, k As Long, lC As Long, T
T = Timer
Sheet1.Range("B7:G65000").ClearContents
With Sheet3
Rng = .Range("C3:N18").Value
For A = 1 To UBound(Rng, 1)
For B = 1 To UBound(Rng, 2)
If Len(Rng(A, B)) Then Names(C + 1) = Rng(A, B): C = C + 1
Next B
Next A
End With
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Filters.Add "Microsoft Excel Files", "*.xls*", 1
If Not .Show = -1 Then
MsgBox "Ban chua chon file", vbCritical, "GPE"
Exit Sub
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Item In .SelectedItems
Set Wk = Workbooks.Open(Item)
TestFile = Filter(Names, Wk.Name, True)
If UBound(TestFile) <> 0 Then
Wk.Close False
Else
For Each Ws In Wk.Sheets
TestSheet = Filter(Names, Ws.Name, True)
If UBound(TestSheet) >= 0 Then
With Ws
WsName = .Name
.Columns("A:G").Delete: .Rows("8:9").Delete
lC = .Range("A7").End(xlToRight).Column
sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value
For i = 2 To UBound(sArr, 2)
k = k + 1
dArr(k, 1) = WsName: dArr(k, 3) = sArr(1, i)
dArr(k, 5) = sArr(2, i): dArr(k, 6) = sArr(3, i)
Next i
End With
End If
Next Ws
Wk.Close False
End If
Next Item
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End With
Sheet1.Range("B7").Resize(k, 6) = dArr
MsgBox "Done in " & Int(Timer - T) & "s.", vbInformation, "GPE"
End Sub
Mình đã sửa lại code, bạn thử xem thế nào, có gì báo mình.
Khi tổng hợp trên máy của mình thì mất hơn 10s.
Mã:Sub SummaryData() Dim Wk As Workbook, Ws As Worksheet, Item As Variant, WsName As String Dim Names(1 To 1000), Rng(), TestFile, TestSheet Dim A As Long, B As Long, C As Long Dim sArr(), dArr(1 To 10000, 1 To 6) Dim i As Long, k As Long, lC As Long, T T = Timer Sheet1.Range("B7:G65000").ClearContents With Sheet3 Rng = .Range("C3:N18").Value For A = 1 To UBound(Rng, 1) For B = 1 To UBound(Rng, 2) If Len(Rng(A, B)) Then Names(C + 1) = Rng(A, B): C = C + 1 Next B Next A End With With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .Filters.Add "Microsoft Excel Files", "*.xls*", 1 If Not .Show = -1 Then MsgBox "Ban chua chon file", vbCritical, "GPE" Exit Sub End If Application.ScreenUpdating = False Application.DisplayAlerts = False For Each Item In .SelectedItems Set Wk = Workbooks.Open(Item) TestFile = Filter(Names, Wk.Name, True) If UBound(TestFile) <> 0 Then Wk.Close False Else For Each Ws In Wk.Sheets TestSheet = Filter(Names, Ws.Name, True) If UBound(TestSheet) >= 0 Then With Ws WsName = .Name .Columns("A:G").Delete: .Rows("8:9").Delete lC = .Range("A7").End(xlToRight).Column sArr = .Range("A7", .Range("A7").End(xlDown)).Resize(, lC).Value For i = 2 To UBound(sArr, 2) k = k + 1 dArr(k, 1) = WsName: dArr(k, 3) = sArr(1, i) dArr(k, 5) = sArr(2, i): dArr(k, 6) = sArr(3, i) Next i End With End If Next Ws Wk.Close False End If Next Item Application.ScreenUpdating = True Application.DisplayAlerts = True End With Sheet1.Range("B7").Resize(k, 6) = dArr MsgBox "Done in " & Int(Timer - T) & "s.", vbInformation, "GPE" End Sub
Không có gì đâu bạn ah.Xin chào vanthinh3101,
Rất xin lỗi bạn vì thời gian qua Oanh Thơ bận chút việc riêng nên không Olnine được.
Xin cảm ơn bạn rất nhiều, Oanh Thơ đã thử code trên code của bạn với file mẫu gửi lên thì đúng là rất nhanh,khoảng 1s. Bạn thao tác hơn 10s có thể là vì code đo thời gian của bạn đặt trước câu lệnh,
....
With Application.FileDialog(msoFileDialogFilePicker)
....
Vì vậy mà thời gian test còn phụ thuộc vào cả thao tác của mỗi người.
Oanh Thơ ngĩ như thế này thì hợp lý hơn ạ ?
....
If Not .Show = -1 Then
MsgBox "Ban chua chon file", vbCritical, "GPE"
Exit Sub
End If
T = Timer
....
Nhưng với file thực thì tốc độ code của bạn có phần chậm hơn so với cách của anh huuthang, theo kiến thức kém cỏi của mình Oanh Thơ cho rằng có thể nguyên nhân coed của bạn chậm là do:
Các tập tin nguồn thực tế của Oanh Thơ nặng, nhiều sheet, nhiều dữ liệu.
Code của bạn là yêu cầu phải mở trực tiếp các tập tin nguồn lên, còn code của anh huuthang không cần phải mở các tập tin nguồn mà sử dụng công thức mảng để lấy dữ liệu trực tiếp từ các tập tin nguồn.
Hic, nếu có điểm nào nhận xét không phải mong bạn và mọi người bỏ qua và góp ý thêm ạ.
Trân trọng cảm ơn,
Them lệnh format TextChào các AC,
Mình có trường hợp cần gộp các file excel thành 1 file. Trong file data , có cột ID, định dạng là text ( "001", "002",....). Khi dùng code (code của AC share) thì khi gộp các file, kết quả la cột ID trở thành định dạng number ("1", "2",...) . Mình muốn Cột ID vẫn có định dạng text ( "001", "002",....).Các AC giúp mình khắc phục lỗi này với. Mình đính kèm 1 file tonghop, 2 file data.
Trân trọng & Cảm ơn
Ngọc Phương
...
If IsArray(aRes) Then
Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).NumberFormat = "@"
Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
End If
....
Thử codeXin chào huuthang_bd, vanthinh3101
Một bài tập nữa tương tự với trường hợp bài #4, Oanh thơ cũng đã loay hoay suốt nhưng chưa giải quyết được vấn đề
nhờ anh huuthang_bd, và bạn vanthinh3101 cùng mọi người trên GPE sửa lại code để lấy dữ liệu theo tập tin gửi kèm với ạ.
Sub Gop_Data()
Dim cn As Object, strSQL As String
Dim dArr As Variant, lR As Long, i As Long, j As Integer
Application.ScreenUpdating = False
With Sheets("T8")
lR = .Range("G" & Rows.Count).End(xlUp).Row
If lR > 2 Then .Range("C3:AM" & lR).ClearContents
End With
With Sheets("Nguon")
lR = .Range("C" & Rows.Count).End(xlUp).Row
If lR < 3 Then MsgBox ("Khong co du lieu nguon, thoat Sub"): Exit Sub
dArr = .Range("C3:AAA" & lR).Value
End With
Set cn = CreateObject("ADODB.Connection")
On Error Resume Next
For i = 1 To UBound(dArr)
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\T8\" & dArr(i, 1) & ";Extended Properties=""Excel 12.0;HDR=No"";"
For j = 2 To UBound(dArr, 2)
If dArr(i, j) = "" Then Exit For
strSQL = "select * from [" & dArr(i, j) & "$D15:AN] where f5 is not null"
With Sheets("T8")
lR = .Range("G" & Rows.Count).End(xlUp).Row
.Range("C" & lR + 1).CopyFromRecordset cn.Execute(strSQL)
End With
Next j
cn.Close
Next i
Set cn = Nothing
Application.ScreenUpdating = True
End Sub