Xin Code Copy nhiều Sheet về Sheet Báo cao theo 2 điều kiện

Liên hệ QC
T

tulaphl

Thành viên chính thức
Tham gia
27/3/08
Bài viết
67
Được thích
66
Xin nhờ Anh, Chị trên GPE viết giúp Code để Copy nhiều Sheet về Sheet báo cáo theo điều kiện từng ngày từ 1 đến 31 và theo từng xe. Tôi có gửi kèm file. Xin chân thành biết ơn!
 

File đính kèm

  • TD hoat dong xe.rar
    1.4 MB · Đọc: 116
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Hình như bạn chưa chỉnh đúng trong file!

TRong bảng BC có xe 8054, nhưng các trang tính có xe nào đó đâu;

Hay đem bán sang TQ rồi(?)

}}}}} --=0 }}}}}
 
Upvote 0
Cám ơn Anh ChanhTQ@, tôi đã nhầm đó là xe 8050. Nhờ Anh sửa giúp lại, thay 8054 thành 8050.
 
Upvote 0
Nhờ Anh, Chị em trên GPE giúp mình đi. XinCams ơn!
 
Upvote 0
Cái code này hơi xương chú lập ạ. Nhìn vào cái biểu hoa hết mắt.
 
Upvote 0
tulaphl đã viết:
Xin nhờ Anh, Chị trên GPE viết giúp Code để Copy nhiều Sheet về Sheet báo cáo theo điều kiện từng ngày từ 1 đến 31 và theo từng xe. Tôi có gửi kèm file. Xin chân thành biết ơn!
Nhấp chuột vào đây để mở rộng...
Code này viết sao lu bu quá, hổng biết chạy nỗi không. File chẳng biết có cái gì mà nặng thấy sợ (41.932kb), tôi gởi code này cho bạn xài thử nhé, gởi file lên đây tốn tài nguyên quá.
PHP: 
Public Sub GPE()
Application.ScreenUpdating = False
On Error Resume Next
Dim sArr(), dArr(), tArr(), Tong(1 To 1, 1 To 257), I As Long, J As Long, K As Long, N As Long, MaxD As Long, Ws As Worksheet, Cll As Range, t As Variant
t = Timer
ReDim tArr(1 To 65000, 1 To 257)
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "BC theo ngay" Then
        sArr = Ws.Range(Ws.[A8], Ws.[A8].End(xlDown).Offset(-1)).Resize(, 257).Value
        For I = 1 To UBound(sArr, 1)
            K = K + 1
            If sArr(I, 1) > MaxD Then MaxD = sArr(I, 1)
            For J = 1 To 257
                tArr(K, J) = sArr(I, J)
            Next J
        Next I
    End If
Next
ReDim dArr(1 To UBound(tArr, 1) * 2, 1 To 257)
K = 0
For N = 1 To MaxD
    For I = 1 To UBound(tArr, 1)
        If tArr(I, 1) = N Then
            K = K + 1
            For J = 1 To 256
                dArr(K, J) = tArr(I, J)
                If J > 2 And J < 256 Then Tong(1, J) = Tong(1, J) + tArr(I, J)
            Next J
        End If
    Next I
    K = K + 1: dArr(K, 2) = "TOTAL:"
    For J = 3 To 255
        dArr(K, J) = Tong(1, J)
        Tong(1, J) = 0
    Next J
Next N
With Sheets("BC theo ngay")
    .[A8:A65000].Resize(, 257).ClearContents
    .[A8:A65000].Resize(, 257).Interior.ColorIndex = xlNone
    .[A8:A65000].Resize(, 257).Font.Bold = False
    .[A8].Resize(K, 257).Value = dArr
    .[A8].Resize(K, 257).Borders.LineStyle = xlContinuous
    For Each Cll In .[B8].Resize(K)
        If Cll.Value = "TOTAL:" Then
            Cll.Offset(, -1).Resize(, 257).Interior.ColorIndex = 36
            Cll.Offset(, -1).Resize(, 257).Font.Bold = True
        End If
    Next
End With
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
tulaphl đã viết:
Xin nhờ Anh, Chị trên GPE viết giúp Code để Copy nhiều Sheet về Sheet báo cáo theo điều kiện từng ngày từ 1 đến 31 và theo từng xe. Tôi có gửi kèm file. Xin chân thành biết ơn!
Nhấp chuột vào đây để mở rộng...
Định làm cho bạn bằng ADO như file của bạn những 257 cột, vượt giới hạn ADO
Vậy viết code VBA cho bạn
- Bạn chú ý : dữ liệu đưa vào phải chuẩn nếu không sẽ gây lỗi, ở đây tại sheet 0349 cột Lái xe (H555) bạn đã nhập sang cột điểm (H254), và còn các lỗi khác mà chưa lường hết được.

[GPECODE=vb]Sub TongHop()Application.ScreenUpdating = False
Dim iR As Long, jC As Long, k As Long, sArr, Res, QtyCar As Long, Tmp, c As Long
Dim Ws As Worksheet, MaxD As Long
Dim Arr(1 To 65536, 1 To 257)
t = Timer
'---1 vong lap Gom du lieu cac sheet vao sArr
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> "BC theo ngay" Then
sArr = Ws.Range(Ws.[A8], Ws.[A8].End(xlDown).Offset(-1)).Resize(, 257).Value
For iR = 1 To UBound(sArr, 1)
k = k + 1
For jC = 1 To 257
Arr(k, jC) = sArr(iR, jC)
Next
If Arr(k, 1) > MaxD Then MaxD = Arr(k, 1) 'tim so ngay lon nhat, 28,29,30,31..tuy cac thang
Next
End If
Next


'So luong xe, tuong ung voi so dong trong 1 ngay
QtyCar = ThisWorkbook.Worksheets.Count - 1


ReDim Res(1 To QtyCar + 1, 1 To 257 * MaxD)
ReDim Tmp(1 To 1, 1 To 257 * MaxD)


'---1 vong lap de tach moi ngay ra 1 cot trong mang
For iR = 1 To k
For jC = 1 To 257
If Arr(iR, 1) <> "" Then
Tmp(1, (Arr(iR, 1) - 1) * 257 + jC) = Tmp(1, (Arr(iR, 1) - 1) * 257 + jC) + 1 'Ghi nho so dong lien tuc tren moi cot
Res(Tmp(1, jC), (Arr(iR, 1) - 1) * 257 + jC) = Arr(iR, jC)
If jC > 2 And jC <> 257 Then
Res(QtyCar + 1, (Arr(iR, 1) - 1) * 257 + jC) = Res(QtyCar + 1, (Arr(iR, 1) - 1) * 257 + jC) + Arr(iR, jC)
ElseIf jC = 1 Then
Res(QtyCar + 1, (Arr(iR, 1) - 1) * 257 + jC) = "Total"
End If
End If
Next
Next


'---1 vong lap de tach cot trong Res va gan xuong sheet


With Sheets("BC theo ngay")
.[A8:A65000].Resize(, 257).ClearContents
.[A8:A65000].Resize(, 257).Interior.ColorIndex = xlNone
.[A8:A65000].Resize(, 257).Font.Bold = False
End With
For c = 1 To MaxD
ReDim sArr(1 To QtyCar + 1, 1 To 257)
For iR = 1 To QtyCar + 1
For jC = 1 To 257
sArr(iR, jC) = Res(iR, (c - 1) * 257 + jC)
Next
Next
With Sheets("BC theo ngay")
[A65536].End(3).Resize(Tmp(1, c) + 1, 257).Offset(1, 0) = sArr
[A65536].End(3).Resize(, 257).Interior.ColorIndex = 36
[A65536].End(3).Resize(, 257).Font.Bold = True
End With
Next
Sheets("BC theo ngay").[A8].Resize([A65536].End(3).Row, 257).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub


[/GPECODE]
 
Lần chỉnh sửa cuối:
Upvote 0
Xin chân thành biết ơn Anh Ba Tê và Anh dhn46, Code của các anh chạy rất tốt, tuy nhiên Code của anh dhn46 chạy hơi chậm, Anh xem có cách nào khắc phục nhanh hơn được không. Chúc các Anh luôn vui vẻ.
 
Upvote 0
tulaphl đã viết:
Xin chân thành biết ơn Anh Ba Tê và Anh dhn46, Code của các anh chạy rất tốt, tuy nhiên Code của anh dhn46 chạy hơi chậm, Anh xem có cách nào khắc phục nhanh hơn được không. Chúc các Anh luôn vui vẻ.
Nhấp chuột vào đây để mở rộng...
Bạn đã có 2 sự lựa chọn, nếu Code bài #7 chậm thì có thể chọn Code bài #6. Hay bạn còn ý gì khác?
 
Upvote 0
Cám ơn dhn46. Tôi thấy khi nhập Code xong thì dung lượng của file tăng lên rất nhiều, bình thường thì chỉ có 1,68 MB, khi nhập Code xong dung lượng tăng lên đến 43,7 MB. có cách nào để giảm được dung lượng đi không?
 
Upvote 0
tulaphl đã viết:
Cám ơn dhn46. Tôi thấy khi nhập Code xong thì dung lượng của file tăng lên rất nhiều, bình thường thì chỉ có 1,68 MB, khi nhập Code xong dung lượng tăng lên đến 43,7 MB. có cách nào để giảm được dung lượng đi không?
Nhấp chuột vào đây để mở rộng...
Hiên tượng File bị phình to ra là do khi gán từ mảng xuống Sheet những 65536 dòng. Có thể xử lý Code, hoặc xử lý bằng tay bằng cách bạn chọn từ dòng có dữ liệu cuối cùng tới dòng 65536 rồi Delete Row.
'------------
Tôi có 1 thắc mắc nhỏ:
Không biết Code bài #6 và #7 tốc độ chenh nhau bao nhiêu?
Bạn đang sử dụng Code nào?

'------------
Dưới đây là Code tôi sửa lại cho bạn, bạn Test thử các Code à trả lời thắc mắc của tôi
Mã: 
Sub TongHop()
Application.ScreenUpdating = False
Dim iR As Long, jC As Long, k As Long, sArr, Res, QtyCar As Long, Tmp
Dim Ttal As Double, ColD As Long
Dim Ws As Worksheet, MaxD As Long
Dim Arr(1 To 65536, 1 To 257)
t = Timer
'---1 vong lap Gom du lieu cac sheet vao sArr
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "BC theo ngay" Then
        sArr = Ws.Range(Ws.[A8], Ws.[A8].End(xlDown).Offset(-1)).Resize(, 257).Value
        For iR = 1 To UBound(sArr, 1)
            k = k + 1
            For jC = 1 To 257
                Arr(k, jC) = sArr(iR, jC)
            Next
            If Arr(k, 1) > MaxD Then MaxD = Arr(k, 1) 'tim so ngay lon nhat, 28,29,30,31..tuy cac thang
        Next
    End If
Next


'So luong xe, tuong ung voi so dong trong 1 ngay
QtyCar = ThisWorkbook.Worksheets.Count - 1
ReDim Res(1 To QtyCar + 1, 1 To 257 * MaxD)
ReDim Tmp(1 To 1, 1 To 257 * MaxD)
'---1 vong lap de tach moi ngay ra 1 cot trong mang
For iR = 1 To k
    For jC = 1 To 257
        If Arr(iR, 1) <> "" Then
            Tmp(1, (Arr(iR, 1) - 1) * 257 + jC) = Tmp(1, (Arr(iR, 1) - 1) * 257 + jC) + 1 'Ghi nho so dong lien tuc tren moi cot
            Res(Tmp(1, jC), (Arr(iR, 1) - 1) * 257 + jC) = Arr(iR, jC)
            If jC > 2 And jC <> 257 Then
                Res(QtyCar + 1, (Arr(iR, 1) - 1) * 257 + jC) = Res(QtyCar + 1, (Arr(iR, 1) - 1) * 257 + jC) + Arr(iR, jC)
            ElseIf jC = 1 Then
                Res(QtyCar + 1, (Arr(iR, 1) - 1) * 257 + jC) = "Total"
            End If
        End If
    Next
Next
'---1 vong lap de tach cot trong Res va gan xuong sheet
Sheets("BC theo ngay").[A8:A65000].EntireRow.Delete
For c = 1 To MaxD
ReDim sArr(1 To QtyCar + 1, 1 To 257)
    For iR = 1 To QtyCar + 1
        For jC = 1 To 257
            sArr(iR, jC) = Res(iR, (c - 1) * 257 + jC)
        Next
    Next
With Sheets("BC theo ngay")
    .[A65536].End(3).Resize(Tmp(1, c) + 1, 257).Offset(1, 0) = sArr
    .[A65536].End(3).Resize(, 257).Interior.ColorIndex = 36
    .[A65536].End(3).Resize(, 257).Font.Bold = True
End With
Next
Sheets("BC theo ngay").[A8].Resize([A65536].End(3).Row, 257).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Xin lỗi dhn46, hôm trước khi nhập xong Code tôi cho chạy ngay thấy chậm hơn Code bài #6, tôi đã vội phản ảnh ngay, khi khởi động lại tôi thấy cũng không chênh lệch là bao. Cám ơn dhn46 đã viết lại Code nhưng khi tôi nhập vào bị lỗi ở vong lap de tach moi ngay ra 1 cot trong mang tại dòng 34 cụ thể: Res(QtyCar + 1, (Arr(iR, 1) - 1) * 257 + jC) = Res(QtyCar + 1, (Arr(iR, 1) - 1) * 257 + jC) + Arr(iR, jC). Nhờ bạn xem lại giúp. Xin cám ơn!
 
Upvote 0
tulaphl đã viết:
Xin lỗi dhn46, hôm trước khi nhập xong Code tôi cho chạy ngay thấy chậm hơn Code bài #6, tôi đã vội phản ảnh ngay, khi khởi động lại tôi thấy cũng không chênh lệch là bao. Cám ơn dhn46 đã viết lại Code nhưng khi tôi nhập vào bị lỗi ở vong lap de tach moi ngay ra 1 cot trong mang tại dòng 34 cụ thể: Res(QtyCar + 1, (Arr(iR, 1) - 1) * 257 + jC) = Res(QtyCar + 1, (Arr(iR, 1) - 1) * 257 + jC) + Arr(iR, jC). Nhờ bạn xem lại giúp. Xin cám ơn!
Nhấp chuột vào đây để mở rộng...
- Bạn không phải xin lỗi, bạn rất có trách nhiệm trong các bài trả lời, và việc tìm hiểu nguyên nhân tại sao chậm cũng là điều tôi thắc mắc.
- Mạn đàm một chút về thuật toán:

+/ Với bài #6: Các bước thực hiện là

1/ Duyệt qua 1 vòng các Sheet để đưa dữ liệu vào mảng (có hơn 800 dòng dữ liệu)
2/ Duyệt qua 31 ngày từ ngày 1 tới 31 của hơn 800 duòng đó => có tới 31*800 vòng lặp
3/ Gán xuống Sheet
Mất tổng 31*800 + 1 vòng lặp

+/ Với bài #7: Các bước là:

1/ Duyệt qua 1 vòng các Sheet để đưa dữ liệu vào mảng (có hơn 800 dòng dữ liệu)
2/ Duyệt 1 vòng qua 800 dòng để gắn vào mảng mỗi ngày (1-31) vào 1 cột => mảng 31 cột
3/ Duyệt 1 vòng qua 800 dòng đó tương ứng duyệt qua các cột để gán xuống sheet
Mất 3 vòng lặp

=> Từ thuật toán đó tôi "đoán" rằng tốc độ sẽ nhanh hơn, nhưng tôi không để ý 1 vấn đề đó là bài #6 gắn dữ liệu 1 lần xuống sheet còn bài #7 mất 31 lần gán, mà thao tác gắn liền với Sheet sẽ rất chậm
- Một điều nữa cả bài #6 và #7 đều chưa chú ý đó là đoạn định dạng cho vùng [A8:A65000] => đây là nguyên nhân gây ra lỗi phình to dữ liệu.

- Vậy tôi vẫn giữ nguyên thuật toán của mình chỉ chỉnh sửa đoạn định dạng vùng [A8:A65536] như bài #11. Bạn dựa vào phân tích có thể khắc phục đoạn gán lên sheet 31 trong Code để cải thiện tốc độ hơn nữa.
Xin nói thêm 1 chút về CSDL của bạn: với cách bố trí của bạn nếu có thêm 1 địa điểm vận chuyển nữa thì bạn sẽ bố trí ra sao khi mà giới hạn Ex đã hết?
Tôi Post File bạn Test và phản hồi.
 

File đính kèm

  • TD hoat dong xe.rar
    1.3 MB · Đọc: 30
Upvote 0
Tuyệt vời, đúng là cao thủ, file chạy rất tốt. Xin chân thành biết ơn bạn dhn46. Về những góp ý của bạn, tôi sẽ cố gắng chỉnh sửa để rút gọn bảng biểu cho phù hợp hơn. Chúc bạn những ngày vui vẻ!
 
Upvote 0
dhn46 đã viết:
- Bạn không phải xin lỗi, bạn rất có trách nhiệm trong các bài trả lời, và việc tìm hiểu nguyên nhân tại sao chậm cũng là điều tôi thắc mắc.
- Mạn đàm một chút về thuật toán:

+/ Với bài #6: Các bước thực hiện là

1/ Duyệt qua 1 vòng các Sheet để đưa dữ liệu vào mảng (có hơn 800 dòng dữ liệu)
2/ Duyệt qua 31 ngày từ ngày 1 tới 31 của hơn 800 duòng đó => có tới 31*800 vòng lặp
3/ Gán xuống Sheet
Mất tổng 31*800 + 1 vòng lặp

+/ Với bài #7: Các bước là:

1/ Duyệt qua 1 vòng các Sheet để đưa dữ liệu vào mảng (có hơn 800 dòng dữ liệu)
2/ Duyệt 1 vòng qua 800 dòng để gắn vào mảng mỗi ngày (1-31) vào 1 cột => mảng 31 cột
3/ Duyệt 1 vòng qua 800 dòng đó tương ứng duyệt qua các cột để gán xuống sheet
Mất 3 vòng lặp

=> Từ thuật toán đó tôi "đoán" rằng tốc độ sẽ nhanh hơn, nhưng tôi không để ý 1 vấn đề đó là bài #6 gắn dữ liệu 1 lần xuống sheet còn bài #7 mất 31 lần gán, mà thao tác gắn liền với Sheet sẽ rất chậm
- Một điều nữa cả bài #6 và #7 đều chưa chú ý đó là đoạn định dạng cho vùng [A8:A65000] => đây là nguyên nhân gây ra lỗi phình to dữ liệu.

- Vậy tôi vẫn giữ nguyên thuật toán của mình chỉ chỉnh sửa đoạn định dạng vùng [A8:A65536] như bài #11. Bạn dựa vào phân tích có thể khắc phục đoạn gán lên sheet 31 trong Code để cải thiện tốc độ hơn nữa.
Xin nói thêm 1 chút về CSDL của bạn: với cách bố trí của bạn nếu có thêm 1 địa điểm vận chuyển nữa thì bạn sẽ bố trí ra sao khi mà giới hạn Ex đã hết?
Tôi Post File bạn Test và phản hồi.
Nhấp chuột vào đây để mở rộng...

Tôi cũng không phân tích được cách làm việc của code, nhưng tôi vẫn làm theo cách cũ bằng code đã sửa lại như vầy, tôi cho chạy trên máy tôi thì thời gian là 0.4 giây, code của bạn 0.726 giây (và kẻ khung thừa 7 dòng dưới)
Nhờ người khác kiểm tra lại xem sao.
 

File đính kèm

  • TD hoat dong xe 2.rar
    1.4 MB · Đọc: 33
Lần chỉnh sửa cuối:
Upvote 0
Ba Tê đã viết:
Tôi cũng không phân tích được cách làm việc của code, nhưng tôi vẫn làm theo cách cũ bằng code đã sửa lại như vầy, tôi cho chạy trên máy tôi thì thời gian là 0.4 giây, code của bạn 0.726 giây (và kẻ khung thừa 7 dòng dưới)
Nhờ người khác kiểm tra lại xem sao.
Nhấp chuột vào đây để mở rộng...
Chạy trên máy của tôi office 2010 code của Bate 2,580078 của dnh46 : 4,673828 và kẻ khung thừa 7 dòng, nhưng trước đó code của thày bate làm tầp tin từ 2,55 Mb phình ra 46,7 Mb thì chay code đã lâu mà khi save lại còn lâu hơn , Phát kinh luôn . Bài toán này học các thày về code thôi, chứ bạn tulaphl bố trí dữ liệu kiểu vậy ...chạy hết "chiều dài đất nước" thì hãi quá !
 
Upvote 0
Ngoai Thanh đã viết:
Chạy trên máy của tôi office 2010 code của Bate 2,580078 của dnh46 : 4,673828 và kẻ khung thừa 7 dòng, nhưng trước đó code của thày bate làm tầp tin từ 2,55 Mb phình ra 46,7 Mb thì chay code đã lâu mà khi save lại còn lâu hơn , Phát kinh luôn . Bài toán này học các thày về code thôi, chứ bạn tulaphl bố trí dữ liệu kiểu vậy ...chạy hết "chiều dài đất nước" thì hãi quá !
Nhấp chuột vào đây để mở rộng...
Bạn chạy file nào vậy?
File tôi chạy xong lưu lại vãn là 2.5Mb mà, làm gì đến 46,..Mb
 

File đính kèm

  • TD hoat dong xe 2.rar
    1.9 MB · Đọc: 10
Upvote 0
Ba Tê đã viết:
Bạn chạy file nào vậy?
File tôi chạy xong lưu lại vãn là 2.5Mb mà, làm gì đến 46,..Mb
Nhấp chuột vào đây để mở rộng...
File của thày OK rồi ạ ? Khi trước copy code bài #6 dán vào module rồi chạy . Sau mở lại kiểm tra , không biết do lỗi gì mà phình ra đến giật mình . Nhà em cũng chưa đối chiếu xem thày đã sửa chỗ nào trong code hay lỗi do máy nhà em chưa biết nữa ! Nhà em đã phải nói " Nhưng trước đó ..." tức không phải file hiện tại .
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

O
  • Question
Nhờ sửa code trích xuất báo cáo
Trả lời
2
Đọc
44
SA_DQ
SA_DQ
PhanTuHuong
Xử lý file Excel bị virus và nặng, chạy ì ạch
    • Thích
    • Yêu thích
Trả lời
6
Đọc
5K
bicutit
B
NCSCVN
Vì sao Vẹt không biết "hót" nhưng cực thích bắt chước tiếng người? Làm sao thuần hóa và chăm sóc chúng?
    • Thích
Trả lời
15
Đọc
395
NCSCVN
NCSCVN
Bạn Đoàn
Em muốn làm bảng phân tích nhanh hơn từ BOM bên khách hàng cho, Mong anh chị giúp đỡ ạ
    • Cười
Trả lời
10
Đọc
328
Bạn Đoàn
Bạn Đoàn
L
Kết hợp chữ và ngày không bị biến đổi định dạng
Trả lời
5
Đọc
120
cantl
C
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom