Chuyên mục xử lý, gỡ rối code VBA (4 người xem)

ndu96081631 · 24/9/13

Topic Những câu hỏi về code, xin giải thích các code... đã quá dài nên mình đóng nó lại và mở topic khác
Tất cả những bài viết liên quan đến việc nhờ giải thích, xử lý và gỡ rối code VBA, các bạn vui lòng đăng tại đây!
Cảm ơn

trungcr105 · 21/10/17

trungcr105 đã viết:
Chào mọi người em đang gặp khó với VBA mong mọi người giúp đỡ với ah!

em muốn làm phần Hyperlink trong cột "File" thì phải làm thế nào ah, em mày mò hoài mà không ra được phần đó.
Em tự mày mò nên cũng chỉ biết hạn chế, mong mọi người giúp đỡ ah
em xin chân thành cảm ơn!

có bác nào giúp e cái này với

Hoang2013 · 22/10/17

Dạ code của em đây ah. Nhờ mọi người xem giùm ah.
Modul loc_du_lieu chạy bình thường ah. Modul tan_suat_hd thì khi chạy là bị reset file excel ah.

Mở module trước bình thường;
Mở cái bạn ghi sau nó báo lỗi "Error in loading DLL"
Đành chịu!

DavidChau · 22/10/17

befaint đã viết:

Bạn đang gọi tới Sheet qua CodeName nên dùng cách sau.

PHP:

Sub ClearRange(ByVal ws As Worksheet)
    With ws
        Union(.Range("P5:P40"), .Range("R5:R40"), .Range("T5:T40"), .Range("U5:Y40"), _
                .Range("AA5:AA40"), .Range("AC5:AC40"), .Range("AE5:AE40"), .Range("AF5:AL40")).ClearContents
    End With
End Sub

Private Sub CommandButton1_Click()
    '....'
    If pass = "123" Then
        Sheet1.Range("D6:F11").ClearContents
        Sheet2.Range("A5:R40").ClearContents
        ClearRange Sheet3
        ClearRange Sheet5
        ClearRange Sheet7
        ClearRange Sheet9
    Else
    '....'
End Sub

Rất cảm ơn bạn đã giúp đỡ. Tôi lại học được ở bạn một bài học mới.

hasitinh · 23/10/17

Hoang2013 đã viết:
Bạn nên đổi lại tên các trang tính, như N01, N02,. . . N10,. . . .
& tham khảo macro sau:

PHP:

Sub TestCopy_GPE() Dim ShName As String ShName = "N" & Right("0" & CStr(Day([i1].Value)), 2) MsgBox ShName Sheets("Index").[K11:P11].Copy Destination:=Sheets(ShName).[D12] MsgBox "Chép Thành Công!" End Sub

Nhờ các anh chỉ giúp mình muốn copy hàng dọc rồi paste vào hàng ngang trên VBA thì làm sao.
Và code " copy Destination" trên đó có y nghỉ gì?
Cảm Ơn mọi người giúp đở.

tueyennhi · 23/10/17

Em có đoạn code sau:

PHP:

...
[AV9].Resize(Rws, 2).Value = FormatDateTime(dArr, vbShortTime)
...

Em muốn kết quả mảng trả về sẽ được định dạng dạng hh:mm, nhưng thử làm như vậy thì báo lỗi ở dòng này. Mọi người chỉ cho em nhé.

befaint · 23/10/17

tueyennhi đã viết:
Mọi người chỉ cho em

Bạn kết bạn với bạn @vova2209 ấy, để nhóm học...
Lần trước làm sao có kết quả ngay thì lần này cũng làm vậy...

tueyennhi · 23/10/17

befaint đã viết:
Bạn kết bạn với bạn @vova2209 ấy, để nhóm học...
Lần trước làm sao có kết quả ngay thì lần này cũng làm vậy...

À mình muốn định dạng luôn cái mảng, nếu làm như hôm trước thì phải thêm dòng lệnh nữa. Nên mình hỏi xem có cách nào gọn hơn không.

HieuCD · 23/10/17

tueyennhi đã viết:
À mình muốn định dạng luôn cái mảng, nếu làm như hôm trước thì phải thêm dòng lệnh nữa. Nên mình hỏi xem có cách nào gọn hơn không.

Vụ nầy ... bạn gởi Mail nhờ ngài Bill tạo thêm lệnh mới Format một lần 2 em Range và Array khác nhau hoàn toàn

befaint · 23/10/17

Đấy là hệ quả của việc không thích ABC... mà cứ thích chơi với Z....
http://www.giaiphapexcel.com/diendan/threads/nhờ-tạo-form-list-box-tìm-kiếm.130636/

Dữ liệu trong mảng chờ gán xuống bảng tính thì nó cũng như dữ liệu nhập từ bàn phím, chuột, copy/paste ở nguồn khác.... vào bảng tính.
Muốn trông dữ liệu trên bảng tính hình thù ra làm sao thì phải do định dạng trên bảng tính quyết định.

hoanghaivqg · 23/10/17

Hoang2013 đã viết:
Mở module trước bình thường;
Mở cái bạn ghi sau nó báo lỗi "Error in loading DLL"
Đành chịu!

Dạ em sử dụng lệnh chỉ chạy office 2010 trở lên. 2007 ko chạy dc, nên báo lỗi Error in loading DLL.
em cài cả office 2007 và 2010 trên máy. ko biết có phải vì vậy mà khi chạy lệnh nó reset ko anh nhỉ?

DavidChau · 26/10/17

befaint đã viết:

Bạn đang gọi tới Sheet qua CodeName nên dùng cách sau.

PHP:

Sub ClearRange(ByVal ws As Worksheet)
    With ws
        Union(.Range("P5:P40"), .Range("R5:R40"), .Range("T5:T40"), .Range("U5:Y40"), _
                .Range("AA5:AA40"), .Range("AC5:AC40"), .Range("AE5:AE40"), .Range("AF5:AL40")).ClearContents
    End With
End Sub

Private Sub CommandButton1_Click()
    '....'
    If pass = "123" Then
        Sheet1.Range("D6:F11").ClearContents
        Sheet2.Range("A5:R40").ClearContents
        ClearRange Sheet3
        ClearRange Sheet5
        ClearRange Sheet7
        ClearRange Sheet9
    Else
    '....'
End Sub

Rất cảm ơn YOU, code chạy rất tốt. Xin YOU dành chút thì giờ giải thích dùm đoạn code để em út học hỏi kinh nghiệm. Rất mong sự giải thích của YOU. Cảm ơn nhiều lắm.
Sub ClearRange(ByVal ws As Worksheet)
With ws
Union(.Range("P5

40"), .Range("R5:R40"), .Range("T5:T40"), .Range("U5:Y40"), _
.Range("AA5:AA40"), .Range("AC5:AC40"), .Range("AE5:AE40"), .Range("AF5:AL40")).ClearContents
End With
End Sub

Private Sub CommandButton1_Click()
'....'
If pass = "123" Then
Sheet1.Range("D6:F11").ClearContents
Sheet2.Range("A5:R40").ClearContents
ClearRange Sheet3
ClearRange Sheet5
ClearRange Sheet7
ClearRange Sheet9
Else
'....'
End Sub

VetMini · 26/10/17

DavidChau đã viết:
Rất cảm ơn YOU, code chạy rất tốt. Xin YOU dành chút thì giờ giải thích dùm đoạn code để em út học hỏi kinh nghiệm. Rất mong sự giải thích của YOU. Cảm ơn nhiều lắm.

Chú bé phèn được yêu oan uổng rồi. Phê nhỉ.

befaint · 26/10/17

VetMini đã viết:
Chú bé phèn được yêu oan uổng rồi. Phê nhỉ.

Lê tê phê ấy ạ.
Hê hê

Kiều Mạnh · 27/10/17

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

dhn46 · 27/10/17

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

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

Kiều Mạnh · 27/10/17

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

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

HieuCD · 27/10/17

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

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

Kiều Mạnh · 27/10/17

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

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

dhn46 · 27/10/17

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

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

befaint · 27/10/17

kieu manh đã viết:
cách nào viết khác nữa

Anh Mạnh thử đoạn sau xem ...

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

Chuyên mục xử lý, gỡ rối code VBA (4 người xem)

Người dùng đang xem chủ đề này

Huyền thoại GPE

Thành viên mới

File đính kèm

Thành viên gắn bó

Search Prettys Womans in your town for night

Thành viên mới

File đính kèm

Thành viên tích cực

|||||||||||||

Thành viên tích cực

Chuyên gia GPE

|||||||||||||

Thành viên mới

Search Prettys Womans in your town for night

Ăn cùng góc phố

|||||||||||||

I don't program, I beat code into submission!!!

File đính kèm

Hướng tới tương lai

I don't program, I beat code into submission!!!

Chuyên gia GPE

I don't program, I beat code into submission!!!

Hướng tới tương lai

|||||||||||||

Đếm ngược thời gian