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

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

dhn46 · 22/11/17

LYSM đã viết:
Bác ơi, vậy trong trường hợp i>ubound(arr,1) thì làm thế nào?

Như file của bạn thì tôi tạm hiểu rằng bạn sử dụng 2 Array, 1 cho cột A (arr) và 1 cho cột X (arr1)

Nếu số phần tử tại cột A < cột X thì cột X sẽ không hiện ra (Code cũ sẽ là giá trị #NA), nếu lớn hơn thì bạn phải nêu muốn cái gì chứ.

chisinhvnn · 22/11/17

Mã:

Private Sub txtTim_Change()
If Me.txtTim = "" Then
    Me.lsbTim.Visible = False
    ElseIf Me.txtTim.Value = "?" Then
        nhaplieu.Hide        (nhaplieu form hiện hành muốn ẩn)
        nhaptaisan.Show    (nhập tài sản form muốn hiện)
    Else
    Me.lsbTim.Visible = True

Mọi người xem giúp code trên sai ở đâu mà bị lỗi ở đoạn code
nhaplieu.Hide (nhaplieu form hiện hành)
nhaptaisan.Show (nhập tài sản form muốn hiện)

Do Nam Trung · 22/11/17

Mình có Record Macro đoạn Code Copy:

Mã:

Sub CopyDulieu()
F.Range("D4:D8,D10:D52,D54:D77,D82:D87").ClearContents
F.Range("I4:I8").Copy
F.Range("D4:D8").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
F.Range("I10:I52").Copy
F.Range("D10:D52").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
F.Range("I54:I77").Copy
F.Range("D54:D77").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
F.Range("I82:I87").Copy
F.Range("D82:D87").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
F.Range("D3").Activate
Application.CutCopyMode = False
End Sub

Khi chạy lệnh thì ok như ý ,Nhưng nó nhẩy nhoáng nhoáng nhìn ko được đẹp mắt và code cũng dài quá...nên nhờ các bạn sửa lại cho nó gọn hơn ,chạy mượt hơn...xin cảm ơn trước.

LYSM · 23/11/17

dhn46 đã viết:
Như file của bạn thì tôi tạm hiểu rằng bạn sử dụng 2 Array, 1 cho cột A (arr) và 1 cho cột X (arr1)

Nếu số phần tử tại cột A < cột X thì cột X sẽ không hiện ra (Code cũ sẽ là giá trị #NA), nếu lớn hơn thì bạn phải nêu muốn cái gì chứ.

Thì đó là cái em đang bị lỗi, cái em muốn là 2 array đó độc lập với nhau, ngày tháng trên mỗi array >13 tháng thì sẽ bị loại bỏ, vì số liệu bên em nhập liên tục nên nếu không bỏ dữ liệu cũ thì sẽ dài mãi file ngày càng nặng nề.

dhn46 · 23/11/17

LYSM đã viết:
Thì đó là cái em đang bị lỗi, cái em muốn là 2 array đó độc lập với nhau, ngày tháng trên mỗi array >13 tháng thì sẽ bị loại bỏ, vì số liệu bên em nhập liên tục nên nếu không bỏ dữ liệu cũ thì sẽ dài mãi file ngày càng nặng nề.

Bạn xem lại khai báo Res1 và sửa thành

Mã:

   ReDim res1(1 To UBound(arr1, 1), 1 To 2)

LYSM · 23/11/17

dhn46 đã viết:
Bạn xem lại khai báo Res1 và sửa thành

Mã:

ReDim res1(1 To UBound(arr1, 1), 1 To 2)

Oh, mắt mũi kém quá, em check mãi Ko ra lỗi. Tks bác nhé

chisinhvnn · 23/11/17

Mình có tạo form tìm kiếm. Khi gõ vào textbox dấu "?" thì form hiện tại ẩn đi, và mở 1 form mới.
Mình viết code như thế này mà bị lỗi nhưng không biết cách khắc phục.

Mã:

Private Sub txtTim_Change()
If Me.txtTim = "" Then
    Me.lsbTim.Visible = False
    ElseIf Me.txtTim.Value = "?" Then
        nhaplieu.Hide
        nhaptaisan.Show
    Else
    Me.lsbTim.Visible = True
Dim arr, sArray

    sArray = Sheet4.Range("A2:E" & Sheet4.[B65000].End(xlUp).Row)
 
    On Error Resume Next

    If Len(Trim(txtTim.Value)) = 0 Then Me.lsbTim.List() = sArray: Exit Sub

    arr = Filter2DArray(sArray, 2, "*" & txtTim.Value & "*", False) 'goc la so 1 "cot tim kiem)

    If Not IsArray(arr) Then
        arr = Filter2DArray(sArray, 3, "*" & txtTim.Value & "*", False)

        If Not IsArray(arr) Then lsbTim.Clear: Exit Sub

    End If

    Me.lsbTim.List() = IIf(Trim(txtTim.Text) = "", sArray, arr)
   
End If


End Sub

Nhờ GPE giúp đỡ. (lỗi lúc đoạn ẩn, hiện form)

dhn46 · 25/11/17

LYSM đã viết:
Oh, mắt mũi kém quá, em check mãi Ko ra lỗi. Tks bác nhé

Bạn bỏ phần On error resume next là thấy ngay ấy mà. Bug lỗi code mà cho phần đó vào thì không kiểm soát được đâu bạn ah.

Binbo2020 · 25/11/17

Hôm trước mình được bạn befaint trợ giúp code phân bổ theo điều kiện nhưng nó bị lỗi khi dữ liệu không sắp xếp theo trình tự.
Mình có nhờ chỉnh lại nhưng không được. Mình đã tự mò và thử chỉnh lại.
code chạy ra đúng kết quả, nhưng khi dữ liệu mình nên khoảng 3.000 dòng thì code chạy mất khoảng 30s.
Mọi người xem giúp mình xem code mình cần thêm gì để có thể chạy nhanh hơn không

Mã:

Sub Phan_Bo1()
    Dim a(), lRow As Long, sMatch As String, eMatch As String
    Dim Res(), TT As Double, KH As Double, i As Long, j As Long
    
    With Sheet5
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
        a = .Range("A7:S" & lRow).Value
        lRow = UBound(a, 1)
        ReDim Res(1 To lRow, 1 To 1)
        For i = 1 To lRow
          
            sMatch = a(i, 1) & "#" & a(i, 2) & "#" & a(i, 3) & "#" & a(i, 4) & "#" & a(i, 5)
            TT = 0: KH = 0
            'Xac dinh so Tieu_thu
            For j = 1 To lRow
                eMatch = a(j, 1) & "#" & a(j, 2) & "#" & a(j, 3) & "#" & a(j, 4) & "#" & a(j, 5)
                If sMatch = eMatch Then TT = TT + a(j, 18)
              
            Next j
            'Xac dinh so Ke_hoach
            For j = 1 To lRow
                eMatch = a(j, 1) & "#" & a(j, 2) & "#" & a(j, 3) & "#" & a(j, 4) & "#" & a(j, 5)
                If sMatch = eMatch Then KH = KH + a(j, 19)
              
            Next j
            'Tinh Phan_bo
            Res(i, 1) = a(i, 19) * TT / KH
        Next i
        .Range("U7").ClearContents
        .Range("U7").Resize(lRow, 1) = Res
    End With
End Sub

Ba Tê · 25/11/17

hongtrang26 đã viết:
Hôm trước mình được bạn befaint trợ giúp code phân bổ theo điều kiện nhưng nó bị lỗi khi dữ liệu không sắp xếp theo trình tự.
Mình có nhờ chỉnh lại nhưng không được. Mình đã tự mò và thử chỉnh lại.
code chạy ra đúng kết quả, nhưng khi dữ liệu mình nên khoảng 3.000 dòng thì code chạy mất khoảng 30s.
Mọi người xem giúp mình xem code mình cần thêm gì để có thể chạy nhanh hơn không

Mã:

Sub Phan_Bo1() Dim a(), lRow As Long, sMatch As String, eMatch As String Dim Res(), TT As Double, KH As Double, i As Long, j As Long With Sheet5 lRow = .Range("A" & Rows.Count).End(xlUp).Row a = .Range("A7:S" & lRow).Value lRow = UBound(a, 1) ReDim Res(1 To lRow, 1 To 1) For i = 1 To lRow sMatch = a(i, 1) & "#" & a(i, 2) & "#" & a(i, 3) & "#" & a(i, 4) & "#" & a(i, 5) TT = 0: KH = 0 'Xac dinh so Tieu_thu For j = 1 To lRow eMatch = a(j, 1) & "#" & a(j, 2) & "#" & a(j, 3) & "#" & a(j, 4) & "#" & a(j, 5) If sMatch = eMatch Then TT = TT + a(j, 18) Next j 'Xac dinh so Ke_hoach For j = 1 To lRow eMatch = a(j, 1) & "#" & a(j, 2) & "#" & a(j, 3) & "#" & a(j, 4) & "#" & a(j, 5) If sMatch = eMatch Then KH = KH + a(j, 19) Next j 'Tinh Phan_bo Res(i, 1) = a(i, 19) * TT / KH Next i .Range("U7").ClearContents .Range("U7").Resize(lRow, 1) = Res End With End Sub

Tôi chỉ nhìn công thức cột T để viết thôi nhé, Tốc độ thì không có dữ liệu nênkhông biết được.

PHP:

Public Sub S_GPE()
Dim sArr(), dArr(), tArr(), I As Long, K As Long, R As Long, Tem As String, Rws As Double
sArr = Range("A7", Range("A7").End(xlDown)).Resize(, 19).Value
R = UBound(sArr)
ReDim tArr(1 To R, 1 To 2)
ReDim dArr(1 To R, 1 To 1)
With CreateObject("Scripting.Dictionary")
For I = 1 To R
    Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 4) & "#" & sArr(I, 5)
    If Not .Exists(Tem) Then
        K = K + 1
        .Item(Tem) = K
        tArr(K, 1) = sArr(I, 18)
    End If
        Rws = .Item(Tem)
        tArr(Rws, 2) = tArr(Rws, 2) + sArr(I, 19)
Next I
    For I = 1 To R
        Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 4) & "#" & sArr(I, 5)
        Rws = .Item(Tem)
        dArr(I, 1) = tArr(Rws, 1) / tArr(Rws, 2) * sArr(I, 19)
    Next I
End With
Range("Y7").Resize(R) = dArr
End Sub

duytmd · 25/11/17

Nhờ BQT xóa bài này giúp e
http://www.giaiphapexcel.com/dienda...-lý-gỡ-rối-code-vba.85576/page-64#post-826556

Binbo2020 · 25/11/17

Ba Tê đã viết:

Tôi chỉ nhìn công thức cột T để viết thôi nhé, Tốc độ thì không có dữ liệu nênkhông biết được.

PHP:

Public Sub S_GPE()
Dim sArr(), dArr(), tArr(), I As Long, K As Long, R As Long, Tem As String, Rws As Double
sArr = Range("A7", Range("A7").End(xlDown)).Resize(, 19).Value
R = UBound(sArr)
ReDim tArr(1 To R, 1 To 2)
ReDim dArr(1 To R, 1 To 1)
With CreateObject("Scripting.Dictionary")
For I = 1 To R
    Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 4) & "#" & sArr(I, 5)
    If Not .Exists(Tem) Then
        K = K + 1
        .Item(Tem) = K
        tArr(K, 1) = sArr(I, 18)
    End If
        Rws = .Item(Tem)
        tArr(Rws, 2) = tArr(Rws, 2) + sArr(I, 19)
Next I
    For I = 1 To R
        Tem = sArr(I, 1) & "#" & sArr(I, 2) & "#" & sArr(I, 4) & "#" & sArr(I, 5)
        Rws = .Item(Tem)
        dArr(I, 1) = tArr(Rws, 1) / tArr(Rws, 2) * sArr(I, 19)
    Next I
End With
Range("Y7").Resize(R) = dArr
End Sub

Cám ơn bạn nhiều, tốc độ khi dữ liệu lên đến 3000 dòng vẫn rất nhanh

duytmd · 25/11/17

Nhờ ae xem giúp code, khi chạy macro "lấy dutoan" ở file sau bị lỗi runtime error9

Ba Tê · 25/11/17

duytmd đã viết:
Nhờ ae xem giúp code, khi chạy macro "lấy dutoan" ở file sau bị lỗi runtime error9

With Sheets("KHOILUONG")
Chẳng có sheet nào tên "KHOILUONG".
Kinh nghiệm đặt tên sheet không nên có dấu cách và dấu tiếng Việt. Muốn dễ nhìn thì nên là "KHOI_LUONG"

duytmd · 25/11/17

Ba Tê đã viết:
With Sheets("KHOILUONG")
Chẳng có sheet nào tên "KHOILUONG".
Kinh nghiệm đặt tên sheet không nên có dấu cách và dấu tiếng Việt. Muốn dễ nhìn thì nên là "KHOI_LUONG"

Thank!, e đã chỉnh được rồi, do sheet khối lượng có khoảng hở mà ko để ý.

haonlh · 26/11/17

Nói chung ít người tạo pivot bằng macro. vì việc này tuy quan trọng nhưng ít phải làm mới.
Nếu bạn thêm dòng ở bảng gốc mà pivot không cho thêm vô thì có thể chọn lại vùng dữ liệu.

Khi RUN macro, nó tạo mới pivot và vẫn mang tên cũ nên lỗi

Do Nam Trung · 28/11/17

Nhờ các bạn xem cho mình cái Code: Worksheet_Change ,ko biết nó còn thiếu cái gì mà nó ko hoạt động ?

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
If [D1] = 0 Then
CommandButton1.Visible = False
Exit Sub
End If
If [D1] >= 0 Then
CommandButton1.Visible = True
Exit Sub
End If
If [G1] = 0 Then
CommandButton2.Visible = False
Exit Sub
End If
If [G1] >= 0 Then
CommandButton2.Visible = True
Exit Sub
End If
End Sub

befaint · 28/11/17

Do Nam Trung đã viết:
If [D1] = 0 Then
If [D1] >= 0 Then

If [G1] = 0 Then

If [G1] >= 0 Then

?

Do Nam Trung · 29/11/17

Thấy bạn befaint có trả lời bằng một dấu ? chắc là bạn ấy ko hiểu câu hỏi của mình hoặc là một lý do nào khác...?

Câu hỏi của mình là:
1, Khi tại ô D1 có dữ liệu bằng không ,thì nút CommandButton1 sẽ bị ẨN và ngược lại....Nếu chỉ sử dụng đoạn Code này thì nó hoạt động bình thường.

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
If [D1] = 0 Then
CommandButton1.Visible = False
Exit Sub
End If
If [D1] >= 0 Then
CommandButton1.Visible = True
Exit Sub
End If
End Sub

2, Mình thêm một điều kiện thứ hai là: Khi tại ô G1 có dữ liệu bằng không ,thì nút CommandButton2 sẽ bị ẨN và ngược lại....Thì Code ko hoạt động.

giaiphap · 29/11/17

Do Nam Trung đã viết:
Thấy bạn befaint có trả lời bằng một dấu ? chắc là bạn ấy ko hiểu câu hỏi của mình hoặc là một lý do nào khác...?
View attachment 187407
Câu hỏi của mình là:
1, Khi tại ô D1 có dữ liệu bằng không ,thì nút CommandButton1 sẽ bị ẨN và ngược lại....Nếu chỉ sử dụng đoạn Code này thì nó hoạt động bình thường.

Mã:

Private Sub Worksheet_Change(ByVal Target As Range) If [D1] = 0 Then CommandButton1.Visible = False Exit Sub End If If [D1] >= 0 Then CommandButton1.Visible = True Exit Sub End If End Sub

2, Mình thêm một điều kiện thứ hai là: Khi tại ô G1 có dữ liệu bằng không ,thì nút CommandButton2 sẽ bị ẨN và ngược lại....Thì Code ko hoạt động.

Vậy sửa lại thế này xem sao.

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
If [D1] = 0 Then
              CommandButton1.Visible = False
Else
              CommandButton1.Visible = True
End If
If [G1] = 0 Then
             CommandButton2.Visible = False
Else
             CommandButton2.Visible = True
End If
End Sub

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

Huyền thoại GPE

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

Thành viên tiêu biểu

Thành viên mới

Thành viên thường trực

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

Thành viên thường trực

Thành viên tiêu biểu

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

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

File đính kèm

Cạo Rồi Khỏi Gội

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

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

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

File đính kèm

Cạo Rồi Khỏi Gội

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

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

Thành viên mới

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

Thành viên mới

==(^o^)==

Facebook

Group