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

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,946
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
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
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
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
Cách của @befaint sao Mạnh chạy thấy Lỗi
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
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
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
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
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ẻ!-.,\;
cái giá hơi bị nặng, em sẽ thử. k đc nhờ huynh tiếp nhá :3
 
Upvote 0
Tôi có cái code như này:
Mã:
Sub Chay()
Dim Min, Max As Date
Dim dem As Integer
Dim Rng As Range
   Set Rng = Sheet1.[B2:B3]
    Min = Application.Min(Rng)
    Max = Application.Max(Rng)
With Sheet2
    .Range("B1:B10000").ClearContents
     If Min > 42004 And Max < 44196 Then
       For dem = 0 To Max - Min
   .Cells(1 + dem, 2) = Min + dem
    Next
End If
End With
Application.ScreenUpdating = True
End Sub
Khi chạy khoảng Min đến Max mà dữ liệu khoảng trên 1000 dòng thì hơi bị chậm, mong anh chị em có cách gì giúp tăng tốc không ạ. Xin cảm ơn
 
Upvote 0
Sub tinh_so()
Dim Ttruoc As Long, Tnay As Long, tang As Long, giam As Long
Set Ttruoc = ThisWorkbook.Worksheets(1).I12
Set Tnay = ThisWorkbook.Worksheets(1).I13
Set tang = ThisWorkbook.Worksheets(1).I14
Set giam = ThisWorkbook.Worksheets(1).I15
MsgBox "So chenh lech thang nay so voi thang truoc la" & Ttruoc - Tnay + tang - giam
End Sub
Các bác giúp hộ e xem cái này sai ở đâu ạ
 
Upvote 0
Tăng tốc thì mình đọc bài sau xem...
PHP:
If Min > 42004 And Max < 44196 Then
    If Min <= Max Then
      Min = CLng(Min): Max = CLng(Max)
        Dim a(), i As Long
        ReDim a(1 To Max - Min + 1, 1 To 1)
        For dem = Min To Max
            i = i + 1
            a(i, 1) = dem
        Next
        .Cells(1, 2).Resize(UBound(a, 1), 1) = a
    End If
End If
 
Lần chỉnh sửa cuối:
Upvote 0
Nhấn F5 mà vàng chỗ nào thì sai chỗ đó.
Đọc bài sau xem...
em xem thì nó bảo kiểu là vba nó không hiểu code em viết ấy, em không biết sai ở đâu cả ạ.
Em viết lại như sau mà vẫn k đc:
"Option Explicit
Sub tinh_chenh_lech()
Dim Ttruoc As Long, Tnay As Long, tang As Long, giam As Long
Set Ttruoc = ThisWorkbook.Worksheets(1).I12.Value
Set Tnay = ThisWorkbook.Worksheets(1).I13.Value
Set tang = ThisWorkbook.Worksheets(1).I14.Value
Set giam = ThisWorkbook.Worksheets(1).I15.Value
MsgBox "So chenh lech thang nay so voi thang truoc la" & chenhlech
End Sub
Function chenhlech(ByVal Ttruoc, ByVal Tnay, ByVal tang, ByVal giam)
chenhlech = Ttruoc - Tnay + tang - giam
End Function"
Muc đích của e là sẽ tính ra số chênh lệch và xuất ra màn hình, số chênh lệch = tháng trước (I12)- tháng này (I13) +tăng (I14)- giảm (I15).
Anh xem chỉ em với ạ
Nhấn F5 mà vàng chỗ nào thì sai chỗ đó.
Đọc bài sau xem...
 
Upvote 0
Hình như các câu lệnh này có vấn đề:
PHP:
Set Ttruoc = ThisWorkbook.Worksheets(1).I12.Value
Set Tnay = ThisWorkbook.Worksheets(1).I13.Value
Set tang = ThisWorkbook.Worksheets(1).I14.Value
Set giam = ThisWorkbook.Worksheets(1).I15.Value

Các biến này (Truoc, Thay, Tang, Giam) không là các biến đối tượng sao lại xài fép gán là 'Set'?; Từ khóa này chỉ dành cho các biến đối tượng mà thôi. Như:
Mã:
 Dim Rng as Range
Set Rng = ThisWorkbook.Worksheets("GPE").[I14]
Tang = Rng.Value

Các địa chỉ ô cần để trong ngoặt, như [I15]
Còn 1 vấn đề không quan trọng nữa, nhưng để sau
 
Upvote 0
Hình như các câu lệnh này có vấn đề:
PHP:
Set Ttruoc = ThisWorkbook.Worksheets(1).I12.Value
Set Tnay = ThisWorkbook.Worksheets(1).I13.Value
Set tang = ThisWorkbook.Worksheets(1).I14.Value
Set giam = ThisWorkbook.Worksheets(1).I15.Value

Các biến này (Truoc, Thay, Tang, Giam) không là các biến đối tượng sao lại xài fép gán là 'Set'?; Từ khóa này chỉ dành cho các biến đối tượng mà thôi. Như:
Mã:
 Dim Rng as Range
Set Rng = ThisWorkbook.Worksheets("GPE").[I14]
Tang = Rng.Value

Các địa chỉ ô cần để trong ngoặt, như [I15]
Còn 1 vấn đề không quan trọng nữa, nhưng để sau
mình sửa lại như sau nhưng vẫn k chạy được bạn ạ:
"Option Explicit
Sub tinh_chenh_lech()
Dim Ttruoc As Long, Tnay As Long, tang As Long, giam As Long
Ttruoc = ThisWorkbook.Worksheets(1).Range("I12").Value
Tnay = ThisWorkbook.Worksheets(1).Range("I13").Value
tang = ThisWorkbook.Worksheets(1).Range("I14").Value
giam = ThisWorkbook.Worksheets(1).Range("I15").Value
MsgBox "So chenh lech thang nay so voi thang truoc la" & chenhlech
End Sub
Function chenhlech(ByVal Ttruoc, ByVal Tnay, ByVal tang, ByVal giam) As formular
chenhlech = Ttruoc - Tnay + tang - giam
End Function"
bạn chỉ mình sai ở đâu với
 
Upvote 0
Cứ sau mỗi mệnh đề gán trị vô biến bạn hỏi xem VBA nó báo cho bạn trị trong biến đó là bao nhiêu?
Ví dụ:
Mã:
 Giam = ThisWorkbook.Worksheets(1).Range("I15").Value
  MsgBox Giam, , "GPE.COM Xin Cho Biêt'

& nếu cần thì lấy giấy bút ra mà ghi lại lần lượt từng em nó một.
 
Upvote 0
Status
Không mở trả lời sau này.
Web KT

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

Back
Top Bottom