Cần giúp đỡ: sửa code VBA để hoạt động trong nhiều trường hợp.

newstar611 · 14/3/19

Xin chào mọi người.

Xin mọi người giúp đỡ chỉnh code để hoạt động tốt hơn, mình có ghi chú trong file.

Chân thành cảm ơn !

snow25 · 14/3/19

newstar611 đã viết:
Xin chào mọi người.

Xin mọi người giúp đỡ chỉnh code để hoạt động tốt hơn, mình có ghi chú trong file.

Chân thành cảm ơn !

Bạn đang viết code Ngược bạn nên thay đổi chiều ngược lại nhé.Đây là ý kiến của mình thôi.

.

newstar611 · 14/3/19

snow25 đã viết:
Bạn đang viết code Ngược bạn nên thay đổi chiều ngược lại nhé.Đây là ý kiến của mình thôi..

Mình đảo hàm if lại thì chạy ok.
Cám ơn Snow25 nhiều.

Bài đã được tự động gộp: 14/3/19

Cho mình hỏi thêm, có cách nào chỉ dùng 1 array mà code vẫn chạy được không, mình muốn tìm hiểu thêm nhiều cách khác

SA_DQ · 14/3/19

Mình thì còn chưa rõ lấy dữ liệu từ các trang họ 'B*' nạp vô những cột nào (của trang TongHop) gọi là thỏa nữa kia đó!
Các trang họ 'B*' làm gì có cột ngày tháng đâu kia chứ?
Theo mình thì trình tự công việc của macro sẽ phải thực thi các công việc theo tuần tự như sau:

1./ Lập danh sách duy nhất tại cột A của trang 'TongHop', chuyện này dự trên các trang tính còn lại;
2./ Tạo vòng lặp thứ nhất duyệt theo cột A duy nhất này
3./ Tạo vòng lặp thứ 2 duyệt qua 3 trang tính còn lại
Trong khi duyệt thì thấy số liệu nào thích ứng thì nạp vô đâu đó, như lên trang tính trực tiếp hay lên mảng khai báo trước tùy hỷ.

B1 có thể xài cách mà bạn đã biết, hay tự làm thủ công hay bán thủ công
& các bước đó chưa đúng, có thể vậy, với dữ liệu hàng hà sa số.
Thân ái!

newstar611 · 14/3/19

SA_DQ đã viết:
Mình thì còn chưa rõ lấy dữ liệu từ các trang họ 'B*' nạp vô những cột nào (của trang TongHop) gọi là thỏa nữa kia đó!
Các trang họ 'B*' làm gì có cột ngày tháng đâu kia chứ?
Theo mình thì trình tự công việc của macro sẽ phải thực thi các công việc theo tuần tự như sau:

1./ Lập danh sách duy nhất tại cột A của trang 'TongHop', chuyện này dự trên các trang tính còn lại;
2./ Tạo vòng lặp thứ nhất duyệt theo cột A duy nhất này
3./ Tạo vòng lặp thứ 2 duyệt qua 3 trang tính còn lại
Trong khi duyệt thì thấy số liệu nào thích ứng thì nạp vô đâu đó, như lên trang tính trực tiếp hay lên mảng khai báo trước tùy hỷ.

B1 có thể xài cách mà bạn đã biết, hay tự làm thủ công hay bán thủ công
& các bước đó chưa đúng, có thể vậy, với dữ liệu hàng hà sa số.
Thân ái!

Ý em là dò theo tên sheet "B*":
- Nếu là BCSX thì lấy những giá trị gắn vào cột "C"
_ Nếu là BCTT_19 thì lấy giá trị gắn vào 2 cột : KV 1 vào cột "E", KV2 vào cột "F", cột "D" = "E"+"F"
_ Nếu là BCTT_18 thì lấy giá trị gắn vào 2 cột : KV 1 vào cột "H", KV2 vào cột "I", cột "G" = "H"+"I"
Những cột này sẽ được tìm theo: ô " rỗng" gần nhất - tính từ ô "A3" ( trong trường hợp này là C,D,E,F,G,H,I)

batman1 · 14/3/19

newstar611 đã viết:
Ý em là dò theo tên sheet "B*":
- Nếu là BCSX thì lấy những giá trị gắn vào cột "C"
_ Nếu là BCTT_19 thì lấy giá trị gắn vào 2 cột : KV 1 vào cột "E", KV2 vào cột "F", cột "D" = "E"+"F"
_ Nếu là BCTT_18 thì lấy giá trị gắn vào 2 cột : KV 1 vào cột "H", KV2 vào cột "I", cột "G" = "H"+"I"
Những cột này sẽ được tìm theo: ô " rỗng" gần nhất - tính từ ô "A3" ( trong trường hợp này là C,D,E,F,G,H,I)

Code chưa xóa dữ liệu cũ.

A - Nếu chỉ có 3 sheet là BCSX, BCTT_19, BCTT_18 và thứ tự nhập bắt buộc phải là BCTT_19 vào D:F, BCTT_18 vào G:I thì dùng Code1

B - Nếu ngoài sheet BCSX có rất nhiều sheet B*** và không bắt buộc sheet B*** nào phải nhập vào D:F, sheet nào B*** vào G:I, sheet nào vào J:L, ..., tức cứ nhập lần lượt vào D:F, G:I, J:L, ... thì dùng code2

2 code chỉ khác nhau chút ít, râu ria thôi, còn trọng tâm là như nhau.

Code1

Mã:

Sub Test()
    Dim dic As Object
    Dim sh As Worksheet, sArr(), tArr(), dArr()
    Dim I As Long, R As Long, lastRow As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With Sheet1
        lastRow = .Range("A" & Rows.count).End(xlUp).Row
        If lastRow < 3 Then Exit Sub
        tArr = .Range("A3:A" & lastRow + 1).Value
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(tArr) - 1
        If tArr(I, 1) <> "" Then dic.Item(tArr(I, 1)) = I
    Next I
            
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name = "BCSX" Or sh.Name = "BCTT_19" Or sh.Name = "BCTT_18" Then
            lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
            If lastRow < 2 Then GoTo continue_
            sArr = sh.Range("A2:A" & lastRow + 1).Resize(, 3).Value
            ReDim dArr(1 To UBound(tArr) - 1, 1 To 3)
            For I = 1 To UBound(sArr) - 1
                If dic.exists(sArr(I, 1)) Then
                    R = dic.Item(sArr(I, 1))
                    If sh.Name = "BCSX" Then
                        dArr(R, 1) = sArr(I, 2)
                    Else
                        dArr(R, 2) = sArr(I, 2)
                        dArr(R, 3) = sArr(I, 3)
                        dArr(R, 1) = sArr(I, 2) + sArr(I, 3)
                    End If
                End If
            Next I
            
            If sh.Name = "BCSX" Then
                Sheet1.Range("C3").Resize(UBound(dArr)).Value = dArr
            ElseIf sh.Name = "BCTT_19" Then
                Sheet1.Range("D3").Resize(UBound(dArr), 3).Value = dArr
            Else
                Sheet1.Range("G3").Resize(UBound(dArr), 3).Value = dArr
            End If
        End If
continue_:
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

----------------------
Code2

Mã:

Sub Test()
    Dim dic As Object
    Dim sh As Worksheet, sArr(), tArr(), dArr()
    Dim I As Long, R As Long, lastRow As Long, count As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    With Sheet1
        lastRow = .Range("A" & Rows.count).End(xlUp).Row
        If lastRow < 3 Then Exit Sub
        tArr = .Range("A3:A" & lastRow + 1).Value
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(tArr) - 1
        If tArr(I, 1) <> "" Then dic.Item(tArr(I, 1)) = I
    Next I
            
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name Like "B*" Then
            lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
            If lastRow < 2 Then GoTo continue_
            sArr = sh.Range("A2:A" & lastRow + 1).Resize(, 3).Value
            ReDim dArr(1 To UBound(tArr) - 1, 1 To 3)
            For I = 1 To UBound(sArr) - 1
                If dic.exists(sArr(I, 1)) Then
                    R = dic.Item(sArr(I, 1))
                    If sh.Name = "BCSX" Then
                        dArr(R, 1) = sArr(I, 2)
                    Else
                        dArr(R, 2) = sArr(I, 2)
                        dArr(R, 3) = sArr(I, 3)
                        dArr(R, 1) = sArr(I, 2) + sArr(I, 3)
                    End If
                End If
            Next I
            
            If sh.Name = "BCSX" Then
                Sheet1.Range("C3").Resize(UBound(dArr)).Value = dArr
            Else
                Sheet1.Range("C3").Offset(, 3 * count + 1).Resize(UBound(dArr), 3).Value = dArr
                count = count + 1
            End If
        End If
continue_:
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

newstar611 · 15/3/19

batman1 đã viết:

Code chưa xóa dữ liệu cũ.

A - Nếu chỉ có 3 sheet là BCSX, BCTT_19, BCTT_18 và thứ tự nhập bắt buộc phải là BCTT_19 vào D:F, BCTT_18 vào G:I thì dùng Code1

B - Nếu ngoài sheet BCSX có rất nhiều sheet B*** và không bắt buộc sheet B*** nào phải nhập vào D:F, sheet nào B*** vào G:I, sheet nào vào J:L, ..., tức cứ nhập lần lượt vào D:F, G:I, J:L, ... thì dùng code2

2 code chỉ khác nhau chút ít, râu ria thôi, còn trọng tâm là như nhau.

Code1

Mã:

Sub Test()
    Dim dic As Object
    Dim sh As Worksheet, sArr(), tArr(), dArr()
    Dim I As Long, R As Long, lastRow As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    With Sheet1
        lastRow = .Range("A" & Rows.count).End(xlUp).Row
        If lastRow < 3 Then Exit Sub
        tArr = .Range("A3:A" & lastRow + 1).Value
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(tArr) - 1
        If tArr(I, 1) <> "" Then dic.Item(tArr(I, 1)) = I
    Next I
         
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name = "BCSX" Or sh.Name = "BCTT_19" Or sh.Name = "BCTT_18" Then
            lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
            If lastRow < 2 Then GoTo continue_
            sArr = sh.Range("A2:A" & lastRow + 1).Resize(, 3).Value
            ReDim dArr(1 To UBound(tArr) - 1, 1 To 3)
            For I = 1 To UBound(sArr) - 1
                If dic.exists(sArr(I, 1)) Then
                    R = dic.Item(sArr(I, 1))
                    If sh.Name = "BCSX" Then
                        dArr(R, 1) = sArr(I, 2)
                    Else
                        dArr(R, 2) = sArr(I, 2)
                        dArr(R, 3) = sArr(I, 3)
                        dArr(R, 1) = sArr(I, 2) + sArr(I, 3)
                    End If
                End If
            Next I
         
            If sh.Name = "BCSX" Then
                Sheet1.Range("C3").Resize(UBound(dArr)).Value = dArr
            ElseIf sh.Name = "BCTT_19" Then
                Sheet1.Range("D3").Resize(UBound(dArr), 3).Value = dArr
            Else
                Sheet1.Range("G3").Resize(UBound(dArr), 3).Value = dArr
            End If
        End If
continue_:
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

----------------------
Code2

Mã:

Sub Test()
    Dim dic As Object
    Dim sh As Worksheet, sArr(), tArr(), dArr()
    Dim I As Long, R As Long, lastRow As Long, count As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    With Sheet1
        lastRow = .Range("A" & Rows.count).End(xlUp).Row
        If lastRow < 3 Then Exit Sub
        tArr = .Range("A3:A" & lastRow + 1).Value
    End With
    Set dic = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(tArr) - 1
        If tArr(I, 1) <> "" Then dic.Item(tArr(I, 1)) = I
    Next I
         
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name Like "B*" Then
            lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
            If lastRow < 2 Then GoTo continue_
            sArr = sh.Range("A2:A" & lastRow + 1).Resize(, 3).Value
            ReDim dArr(1 To UBound(tArr) - 1, 1 To 3)
            For I = 1 To UBound(sArr) - 1
                If dic.exists(sArr(I, 1)) Then
                    R = dic.Item(sArr(I, 1))
                    If sh.Name = "BCSX" Then
                        dArr(R, 1) = sArr(I, 2)
                    Else
                        dArr(R, 2) = sArr(I, 2)
                        dArr(R, 3) = sArr(I, 3)
                        dArr(R, 1) = sArr(I, 2) + sArr(I, 3)
                    End If
                End If
            Next I
         
            If sh.Name = "BCSX" Then
                Sheet1.Range("C3").Resize(UBound(dArr)).Value = dArr
            Else
                Sheet1.Range("C3").Offset(, 3 * count + 1).Resize(UBound(dArr), 3).Value = dArr
                count = count + 1
            End If
        End If
continue_:
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Cám ơn batman1.

Vì mình muốn làm liên tiếp 12 tháng nên ko có code xóa dữ liệu, và gắn dữ liệu vào các cột sẽ thay đổi sau mỗi tháng nên các cột C,D,E,F,G,H,I đều phải tìm lại sau mỗi lần chạy code.

Cần giúp đỡ: sửa code VBA để hoạt động trong nhiều trường hợp.

newstar611

Thành viên chính thức

File đính kèm

snow25

Thành viên gạo cội

newstar611

Thành viên chính thức

SA_DQ

/(hông là gì!

newstar611

Thành viên chính thức

batman1

Thành viên gạo cội

newstar611

Thành viên chính thức

File đính kèm

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

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

Đếm ngược thời gian