Chuyên mục xử lý, gỡ rối code VBA

Liên hệ QC
Status
Không mở trả lời sau này.
ndu96081631

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia
5/6/08
Bài viết
30,703
Được thích
53,930
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Tình Hình là mình đang Viết 1 khúc code tổng hợp dữ liệu từ nhiều Sheet khác nhau cộng dồn lại một Mảng xong chia 3 phần gán kết quả xuống Sheet TongHop ...Mà chưa làm được Mong các Bạn trợ giúp

Nó sẻ phát Sinh 3 trường Hợp như sau:

1/ Trên 3 Sheet AABB, AAAA, ABAB có dữ liệu 2 cột và 10 dòng như nhau thì nó sẻ gán kết quả xuống sheet TongHop 3 Phần như nhau như Sheet KetQuaMongMuon

2/ Nếu 3 Sheet cộng lại có 32 dòng thì có 1 phần là 10 dòng còn lại 2 phần kia là 11 dòng

3/ Nếu 3 Sheet Cộng lại Có 31 dòng thì có 2 phần là 10 dòng còn lại 1 phần kia là 11 dòng

4/ Lưu ý dữ liệu các Sheet cần tổng hợp luôn luôn biến động không cố định ...

Mình có viết code sau vì sẻ có nhiều Sheet khác nữa nên ko sử dụng For Each mà sử dụng 1 Array để duyệt Sheet .... code chạy tốt nhưng chưa hình dung ra cách chia kết quả gán xuống sheet như nêu trên Mong các Bạn Trợ giúp ......

Xin cảm ơn
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(k * 5, 2).ClearContents
            .Resize(k, 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
 

File đính kèm

  • TongHop.xlsb
    30.5 KB · Đọc: 12
Lần chỉnh sửa cuối:
Upvote 0
kieu manh đã viết:
Tình Hình là mình đang Viết 1 khúc code tổng hợp dữ liệu từ nhiều Sheet khác nhau cộng dồn lại một Mảng xong chia 3 phần gán kết quả xuống Sheet TongHop ...Mà chưa làm được Mong các Bạn trợ giúp

Nó sẻ phát Sinh 3 trường Hợp như sau:

1/ Trên 3 Sheet AABB, AAAA, ABAB có dữ liệu 2 cột và 10 dòng như nhau thì nó sẻ gán kết quả xuống sheet TongHop 3 Phần như nhau như Sheet KetQuaMongMuon

2/ Nếu 3 Sheet cộng lại có 32 dòng thì có 1 phần là 10 dòng còn lại 2 phần kia là 11 dòng

3/ Nếu 3 Sheet Cộng lại Có 31 dòng thì có 2 phần là 10 dòng còn lại 1 phần kia là 11 dòng

4/ Lưu ý dữ liệu các Sheet cần tổng hợp luôn luôn biến động không cố định ...

Mình có viết code sau vì sẻ có nhiều Sheet khác nữa nên ko sử dụng For Each mà sử dụng 1 Array để duyệt Sheet .... code chạy tốt nhưng chưa hình dung ra cách chia kết quả gán xuống sheet như nêu trên Mong các Bạn Trợ giúp ......

Xin cảm ơn
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(k * 5, 2).ClearContents
            .Resize(k, 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Không biết có phải ý bạn như dưới đây hay không?

Có n phần tử, chia cho k, kết quả T là số nguyên sao cho (T1+T2+.....+Tk) = n

Nếu hiểu đúng thì ý tưởng cua mình như sau:

m= Mod(n, k) là tập số từ 0 -> k+1

m = 0 => Số phần tử mỗi cột T1 = T2 =...=Tk = n/k
m = 1 => Số phần tử mỗi cột T1 = T2 =...=T(k-m) = Int(n/k), Tk = Int(n/k) + 1
m = 2 => Số phần tử mỗi cột T1 = T2=...=T(k-m)= Int(n/k), T(k-2) = T(k-1) = T(k) = Int(n/k)+1
m = i => Số phần tử mỗi cột T1 = T2=...=T(k-i) = Int(n/k), T(k-i) = T(k-i-1) ....=T(k) = Int(n/k)+1

Code chia sẽ là
Mã: 
Sub ChiaCot()
Dim n As Long
Dim k As Long
Dim m As Long
Dim MinSoPhanTuTrongCot As Long

n = 100
k = 6

MinSoPhanTuTrongCot = Int(n / k)
m = n - Int(n / k) * k

For i = 1 To k - m
    Cells(1, i) = MinSoPhanTuTrongCot
Next

For i = k - m + 1 To k
    Cells(1, i) = MinSoPhanTuTrongCot + 1
Next

End Sub
 
Upvote 0
dhn46 đã viết:
Không biết có phải ý bạn như dưới đây hay không?

Có n phần tử, chia cho k, kết quả T là số nguyên sao cho (T1+T2+.....+Tk) = n

Nếu hiểu đúng thì ý tưởng cua mình như sau:

m= Mod(n, k) là tập số từ 0 -> k+1

m = 0 => Số phần tử mỗi cột T1 = T2 =...=Tk = n/k
m = 1 => Số phần tử mỗi cột T1 = T2 =...=T(k-m) = Int(n/k), Tk = Int(n/k) + 1
m = 2 => Số phần tử mỗi cột T1 = T2=...=T(k-m)= Int(n/k), T(k-2) = T(k-1) = T(k) = Int(n/k)+1
m = i => Số phần tử mỗi cột T1 = T2=...=T(k-i) = Int(n/k), T(k-i) = T(k-i-1) ....=T(k) = Int(n/k)+1

Code chia sẽ là
Mã: 
Sub ChiaCot()
Dim n As Long
Dim k As Long
Dim m As Long
Dim MinSoPhanTuTrongCot As Long

n = 100
k = 6

MinSoPhanTuTrongCot = Int(n / k)
m = n - Int(n / k) * k

For i = 1 To k - m
    Cells(1, i) = MinSoPhanTuTrongCot
Next

For i = k - m + 1 To k
    Cells(1, i) = MinSoPhanTuTrongCot + 1
Next

End Sub
Nhấp chuột vào đây để mở rộng...
Mạnh thuộc thành phần tự mò tự học coi mà ko hiểu gì hết ... Nếu được Bạn viết dùm 1 code mẫu hoàn chỉnh Mạnh coi là hiểu à
Xin cảm ơn
 
Upvote 0
kieu manh đã viết:
Tình Hình là mình đang Viết 1 khúc code tổng hợp dữ liệu từ nhiều Sheet khác nhau cộng dồn lại một Mảng xong chia 3 phần gán kết quả xuống Sheet TongHop ...Mà chưa làm được Mong các Bạn trợ giúp

Nó sẻ phát Sinh 3 trường Hợp như sau:

1/ Trên 3 Sheet AABB, AAAA, ABAB có dữ liệu 2 cột và 10 dòng như nhau thì nó sẻ gán kết quả xuống sheet TongHop 3 Phần như nhau như Sheet KetQuaMongMuon

2/ Nếu 3 Sheet cộng lại có 32 dòng thì có 1 phần là 10 dòng còn lại 2 phần kia là 11 dòng

3/ Nếu 3 Sheet Cộng lại Có 31 dòng thì có 2 phần là 10 dòng còn lại 1 phần kia là 11 dòng

4/ Lưu ý dữ liệu các Sheet cần tổng hợp luôn luôn biến động không cố định ...

Mình có viết code sau vì sẻ có nhiều Sheet khác nữa nên ko sử dụng For Each mà sử dụng 1 Array để duyệt Sheet .... code chạy tốt nhưng chưa hình dung ra cách chia kết quả gán xuống sheet như nêu trên Mong các Bạn Trợ giúp ......

Xin cảm ơn
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(k * 5, 2).ClearContents
            .Resize(k, 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Thử code sau
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long, sRow, m, n, j, ik
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        m = Application.RoundUp(k / 3, 0)
        n = 2 - ((k - 1) Mod 3)
        ReDim Arr(1 To m, 1 To 6)
        For j = 1 To 3
          If j <= n Then sRow = m - 1 Else sRow = m
          For i = 1 To sRow
            ik = ik + 1
            Arr(i, j * 2 - 1) = Res(ik, 1)
            Arr(i, j * 2) = Res(ik, 2)
          Next i
        Next j
        With Sh.Range("A1")
            .Resize(k * 5, 6).ClearContents
            .Resize(m, 6) = Arr
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
Thử code sau
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long, sRow, m, n, j, ik
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        m = Application.RoundUp(k / 3, 0)
        n = 2 - ((k - 1) Mod 3)
        ReDim Arr(1 To m, 1 To 6)
        For j = 1 To 3
          If j <= n Then sRow = m - 1 Else sRow = m
          For i = 1 To sRow
            ik = ik + 1
            Arr(i, j * 2 - 1) = Res(ik, 1)
            Arr(i, j * 2) = Res(ik, 2)
          Next i
        Next j
        With Sh.Range("A1")
            .Resize(k * 5, 6).ClearContents
            .Resize(m, 6) = Arr
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Tuyệt Vời .........Cảm ơn Bạn
Mình Muốn mở rộng học thêm 1 chút ....

Ngoài cách này còn cách nào viết khác nữa ko .... Ý mình là cùng một sự việc đó ta có thể viết được mấy cách .... Tính Mình hay thích nghiên cứu và khai thác vấn đề ở nhiều khía cạnh khác nhau đó mà .... Mục đích để Học thêm
 
Upvote 0
kieu manh đã viết:
Mạnh thuộc thành phần tự mò tự học coi mà ko hiểu gì hết ... Nếu được Bạn viết dùm 1 code mẫu hoàn chỉnh Mạnh coi là hiểu à
Xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Dhn46 múa rìu qua mắt thợ rồi bạn
Mã: 
Public Sub TongHop1()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 2), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        '------------------------------------
        Dim n As Long
        Dim k1 As Long
        Dim m As Long
        Dim r As Long
        Dim MinSoPhanTuTrongCot As Long
        '------------------------------------
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    Res(k, 1) = Arr(i, 1)
                    Res(k, 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(k * 5, 2).ClearContents
            .Resize(k, 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
        '--------------------------------------
        With Sheets("TongHop")
            Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
        End With
        n = UBound(Arr, 1)
        k1 = 3
        MinSoPhanTuTrongCot = Int(n / k1)
        m = n - Int(n / k1) * k1
        With Sheets("KetQuaMongMuon")
        .UsedRange.ClearContents
        For i = 1 To k1 - m
            For r = 1 To MinSoPhanTuTrongCot
                .Cells(r, 1 + (i - 1) * 2) = Arr(r + (i - 1) * MinSoPhanTuTrongCot, 1)
                .Cells(r, 2 + (i - 1) * 2) = Arr(r + (i - 1) * MinSoPhanTuTrongCot, 2)
            Next
        Next
        For i = k1 - m + 1 To k1
            For r = 1 To MinSoPhanTuTrongCot + 1
                .Cells(r, 1 + (i - 1) * 2) = Arr(r + (i - 1) * MinSoPhanTuTrongCot, 1)
                .Cells(r, 2 + (i - 1) * 2) = Arr(r + (i - 1) * MinSoPhanTuTrongCot, 2)
            Next
        Next
        End With
        '----------------------------------------
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
kieu manh đã viết:
cách nào viết khác nữa
Nhấp chuột vào đây để mở rộng...
Anh Mạnh thử đoạn sau xem ... :p
PHP: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(), SheetName(), Sht(), Result
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    ReDim Preserve Res(1 To 2, 1 To k)
                    Res(1, k) = Arr(i, 1)
                    Res(2, k) = Arr(i, 2)
                End If
            Next
        Next
        If k Then
            Result = SplitArr2D(TransposeArr2D(Res))
            With Sh.Range("A1")
                .Resize(65536, 6).ClearContents
                .Resize(UBound(Result, 1), 6) = Result
            End With
        End If
        'Call ChangeFont(Sh, Range("A1"))
        'Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
'---------------'
Private Function TransposeArr2D(ByVal arSrc)
    Dim Arr, Result(), maxC As Long, j As Long, k As Long
    Arr = arSrc
    maxC = UBound(Arr, 1)
    ReDim Result(1 To UBound(Arr, 2), 1 To maxC)
    For k = 1 To UBound(Arr, 2)
        For j = 1 To maxC
            Result(k, j) = Arr(j, k)
        Next j
    Next k
    TransposeArr2D = Result
End Function
'---------------'
Private Function SplitArr2D(ByVal arSrc)
    Rem == chia mang 2 chieu thanh 3 phan
    If IsArray(arSrc) = False Then Exit Function
    Dim Arr, Result(), maxR As Long, N As Long, d As Long
    Dim i As Long, j As Long, k As Long
    Arr = arSrc
    maxR = UBound(Arr, 1)
    N = WorksheetFunction.Quotient(maxR, 3)
    d = maxR Mod 3
    ReDim Result(1 To N + 1, 1 To 6)
    j = 1: k = 1
    For i = 1 To maxR
        Select Case d
            Case 0, 1
                If j = N + 1 And i < maxR Then j = 1: k = k + 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
            Case 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
                If i = N Then j = 1: k = k + 2
                If i = 2 * N + 1 Then j = 1: k = k + 2
        End Select
    Next i
    SplitArr2D = Result
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
befaint đã viết:
Anh Mạnh thử đoạn sau xem ... :p
PHP: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(), SheetName(), Sht(), Result
        Dim i As Long, k As Long, x As Long
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        For x = 1 To UBound(Sht)
            With Sheets(Sht(x))
                Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    k = k + 1
                    ReDim Preserve Res(1 To 2, 1 To k)
                    Res(1, k) = Arr(i, 1)
                    Res(2, k) = Arr(i, 2)
                End If
            Next
        Next
        If k Then
            Result = SplitArr2D(TransposeArr2D(Res))
            With Sh.Range("A1")
                .Resize(65536, 6).ClearContents
                .Resize(UBound(Result, 1), 6) = Result
            End With
        End If
        'Call ChangeFont(Sh, Range("A1"))
        'Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
'---------------'
Private Function TransposeArr2D(ByVal arSrc)
    Dim Arr, Result(), maxC As Long, j As Long, k As Long
    Arr = arSrc
    maxC = UBound(Arr, 1)
    ReDim Result(1 To UBound(Arr, 2), 1 To maxC)
    For k = 1 To UBound(Arr, 2)
        For j = 1 To maxC
            Result(k, j) = Arr(j, k)
        Next j
    Next k
    TransposeArr2D = Result
End Function
'---------------'
Private Function SplitArr2D(ByVal arSrc)
    Rem == chia mang 2 chieu thanh 3 phan
    If IsArray(arSrc) = False Then Exit Function
    Dim Arr, Result(), maxR As Long, N As Long, d As Long
    Dim i As Long, j As Long, k As Long
    Arr = arSrc
    maxR = UBound(Arr, 1)
    N = WorksheetFunction.Quotient(maxR, 3)
    d = maxR Mod 3
    ReDim Result(1 To N + 1, 1 To 6)
    j = 1: k = 1
    For i = 1 To UBound(Arr, 1)
        Select Case d
            Case 0, 1
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
                If i Mod N = 0 Then j = 1: k = k + 2
            Case 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
                If i = N Then j = 1: k = k + 2
                If i = 2 * N + 1 Then j = 1: k = k + 2
        End Select
    Next i
    SplitArr2D = Result
End Function
Nhấp chuột vào đây để mở rộng...
Cảm ơn các Bạn ...
Vậy là cùng 1 vấn đề Mạnh học được 3 cách xử lý khác nhau

Cách của @befaint sao Mạnh chạy thấy LỗiCapture.PNG
 
Upvote 0
Góp thêm một cách
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 6), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long, sRow, m, n, j, sk, S
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        S = UBound(Sht)
        ReDim Sarr(1 To S)
        For x = 1 To S
            sk = sk + Sheets(Sht(x)).[A65536].End(3).Row
        Next x
        m = Application.RoundUp(sk / S, 0)
        n = S - 1 - ((sk - 1) Mod S)
        For x = 1 To S
            With Sheets(Sht(x))
              Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    If k = sRow Or k = 0 Then
                      k = 0
                      j = j + 1
                      If j <= n Then sRow = m - 1 Else sRow = m
                    End If
                    k = k + 1
                    Res(k, j * 2 - 1) = Arr(i, 1)
                    Res(k, j * 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(.Offset(65500, S * 2).End(xlUp).Row, S * 2).ClearContents
            .Resize(m, S * 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
Chúc các bạn cuối tuần vui
 
Upvote 0
HieuCD đã viết:
Góp thêm một cách
Mã: 
Public Sub TongHop()
    Application.ScreenUpdating = False
        Dim Sh As Worksheet
        Dim Arr(), Res(1 To 65536, 1 To 6), SheetName(), Sht()
        Dim i As Long, k As Long, x As Long, sRow, m, n, j, sk, S
        Set Sh = ThisWorkbook.Worksheets(Sheet4.Name)
        SheetName = Array(Sheet1.Name, Sheet2.Name, Sheet3.Name)
        Call GetSheetName(SheetName, Sht())
        S = UBound(Sht)
        ReDim Sarr(1 To S)
        For x = 1 To S
            sk = sk + Sheets(Sht(x)).[A65536].End(3).Row
        Next x
        m = Application.RoundUp(sk / S, 0)
        n = S - 1 - ((sk - 1) Mod S)
        For x = 1 To S
            With Sheets(Sht(x))
              Arr = .Range("A1", .[A65536].End(3).Resize(, 2)).Value
            End With
            For i = 1 To UBound(Arr)
                If Arr(i, 1) <> Empty Then
                    If k = sRow Or k = 0 Then
                      k = 0
                      j = j + 1
                      If j <= n Then sRow = m - 1 Else sRow = m
                    End If
                    k = k + 1
                    Res(k, j * 2 - 1) = Arr(i, 1)
                    Res(k, j * 2) = Arr(i, 2)
                End If
            Next
        Next
        With Sh.Range("A1")
            .Resize(.Offset(65500, S * 2).End(xlUp).Row, S * 2).ClearContents
            .Resize(m, S * 2) = Res
        End With
        Call ChangeFont(Sh, Range("A1"))
        Call FixColumnsRows(Sh)
    Application.ScreenUpdating = True
End Sub
Chúc các bạn cuối tuần vui
Nhấp chuột vào đây để mở rộng...
Quả thực chạy cộng , trừ, nhân và Chia trực tiếp trên Mảng luôn tốc độ rất nhanh

Cách này bỏ 1 vòng For rất hay nhưng lấy S = UBound(Sht) = 3 sheet để chia 3 cột ... nếu ta thêm 1 Sheet là CCCC nữa là lỗi code phải sửa lại ở dưới ... còn cách Bạn viết Lần 1 ta muốn thêm bao nhiêu Sheet OK hết ...
Cảm ơn Bạn
 
Lần chỉnh sửa cuối:
Upvote 0
kieu manh đã viết:
Cách của @befaint sao Mạnh chạy thấy Lỗi
Nhấp chuột vào đây để mở rộng...
Em sửa lại chỗ lỗi. Anh kiểm tra thử nhé.
PHP: 
Private Function SplitArr2D(ByVal arSrc)
    Rem == chia mang 2 chieu thanh 3 phan
    If IsArray(arSrc) = False Then Exit Function
    Dim Arr, Result(), maxR As Long, N As Long, d As Long
    Dim i As Long, j As Long, k As Long
    Arr = arSrc
    maxR = UBound(Arr, 1)
    N = WorksheetFunction.Quotient(maxR, 3)
    d = maxR Mod 3
    ReDim Result(1 To N + 1, 1 To 6)
    j = 1: k = 1
    For i = 1 To maxR
        Select Case d
            Case 0, 1
                If j = N + 1 And i < maxR Then j = 1: k = k + 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
            Case 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
                If i = N Then j = 1: k = k + 2
                If i = 2 * N + 1 Then j = 1: k = k + 2
        End Select
    Next i
    SplitArr2D = Result
End Function
 
Upvote 0
befaint đã viết:
Em sửa lại chỗ lỗi. Anh kiểm tra thử nhé.
PHP: 
Private Function SplitArr2D(ByVal arSrc)
    Rem == chia mang 2 chieu thanh 3 phan
    If IsArray(arSrc) = False Then Exit Function
    Dim Arr, Result(), maxR As Long, N As Long, d As Long
    Dim i As Long, j As Long, k As Long
    Arr = arSrc
    maxR = UBound(Arr, 1)
    N = WorksheetFunction.Quotient(maxR, 3)
    d = maxR Mod 3
    ReDim Result(1 To N + 1, 1 To 6)
    j = 1: k = 1
    For i = 1 To maxR
        Select Case d
            Case 0, 1
                If j = N + 1 And i < maxR Then j = 1: k = k + 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
            Case 2
                Result(j, k) = Arr(i, 1)
                Result(j, k + 1) = Arr(i, 2)
                j = j + 1
                If i = N Then j = 1: k = k + 2
                If i = 2 * N + 1 Then j = 1: k = k + 2
        End Select
    Next i
    SplitArr2D = Result
End Function
Nhấp chuột vào đây để mở rộng...
Chạy tốt Mọi .......... Cái cho hết lên mãng tính nó chạy nhanh hơn trên Cells
 
Upvote 0
Các anh giúp em lập hàm này với ạ: Dò tìm giá trị ô I12 từ một trong 2 sheet vs các điều kiện sau:
- Nếu I8 là "Chuyển khoản" thì tìm trong Sheet "CHUYEN KHOAN", Nếu I8 là "Tiền mặt" dò trong Sheet "TIEN MAT"
- Khi dò tìm giá trị tại I8 ở mỗi sheet lại thỏa mãn điều kiện I8 là giá trị tại ô là giao của hàng và cột được tìm như sau:
+ Hàng là hàng có chứa "MÃ ĐVQHNS" tại ô I9
+ Cột là cột chứa số tháng có giá trị = I11 - 1
E cảm ơn các anh ạ
 

File đính kèm

  • Theo doi bien dong luong.xls
    76.5 KB · Đọc: 3
Upvote 0
Muốn có hàm thì đây, xin mời:
 

File đính kèm

  • GPE.rar
    22.3 KB · Đọc: 8
Upvote 0
hjx hjx ..... e nhầm anh ơi, code VBA ạ. Em nhầm. Sry anhhhh. Anh giúp em cái. E sửa bài nha
Nhấp chuột vào đây để mở rộng...
Bạn fải trả giá cho sự nhầm lẫn của mình đi chứ; bằng 1 trong các cách sau:

(1) Cứ để hàm í mà xài, dù nắng mưa hay chậm nhanh gì đó cũng đán!
(2) Tự tìm cách mà viết thành 1 macro sự kiện gắn liền với [I11], với sự tham khảo của hàm trên
(3) Lập bài đăng mới hay chờ ai đi ngang có lòng hảo tâm thực hiện macro mới cho bạn!

Chúc ngày cuối tuần vui vẻ!-.,\;
 
Upvote 0
Nhờ mấy anh chỉ em cái chổ khai báo textbox như thế nào để lấy giá trị như hàm dưới
PHP: 
Private Sub CommandButton318_Click() '---------ver2
Dim MyRan As Range
Dim Arr As Variant
Dim Irow As Integer, Icl As Integer, k As Integer
Set MyRan = Range("C45:H65")
For Irow = 0 To MyRan.Rows.Count
Debug.Print Irow
For Icl = 1 To 6
k = k
If Worksheets("1").Range("B45").Offset(Irow, Icl).Interior.ColorIndex = -4142 Then
Debug.Print Worksheets("1").Range("B45").Offset(Irow, Icl).Value
TextBox(k + 1) = Worksheets("1").Range("B45").Offset(Irow, Icl).Value
' Em khong biết làm thế nào để khai báo cái textbox làm sao???
Debug.Print "K:" & k
End If
 Next
  Next Irow
       End Sub
End Sub
 
Upvote 0
SA_DQ đã viết:
Bạn fải trả giá cho sự nhầm lẫn của mình đi chứ; bằng 1 trong các cách sau:

(1) Cứ để hàm í mà xài, dù nắng mưa hay chậm nhanh gì đó cũng đán!
(2) Tự tìm cách mà viết thành 1 macro sự kiện gắn liền với [I11], với sự tham khảo của hàm trên
(3) Lập bài đăng mới hay chờ ai đi ngang có lòng hảo tâm thực hiện macro mới cho bạn!

Chúc ngày cuối tuần vui vẻ!-.,\;
Nhấp chuột vào đây để mở rộng...
cái giá hơi bị nặng, em sẽ thử. k đc nhờ huynh tiếp nhá :3
 
Upvote 0
Status
Không mở trả lời sau này.
Web KT

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

Bich2B
lỗi định dạng ngày không đọc được công thức excel
Trả lời
6
Đọc
60
Bich2B
Bich2B
P
Finest Сasual Dating - Verified Damsels
Trả lời
0
Đọc
6
phuoctho2009
P
A
Đếm dữ liệu với điều kiện
Trả lời
12
Đọc
130
adambaylin
A
S
Nhờ giúp đỡ code in toàn bộ danh sách có điều kiện
Trả lời
2
Đọc
67
S.Ha
S
A
Excel thiếu dữ liệu
Trả lời
4
Đọc
121
Mr.hieudoanxd
Mr.hieudoanxd
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