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

taihuong · 28/9/17

Anh chị giúp em với.
Trong file của em có 2 code, 1 code để em click vào icon sẽ tự động insert dòng và copy công thức của dòng trên xuống, nhưng file em chia sẻ cho người khác nhập nên khóa công thức bằng protect của excel, nên em cho thêm 1 code để vba vẫn chạy được khi sheet bị bảo vệ, 2 code này em lấy trên web của mình, nhưng khi tắt file đi và mở lại thì em phải unprotect, run lại code rồi protect lại mới được cho người khác dùng được, việc này rất bất tiện, mọi người có thể chỉnh giúp em code 2 để nó tự chạy khi mở file mà em không cần phải làm mấy thao tác trên được không ạ, với em muốn chỉnh để cho code này chạy trên toàn bộ workbook mà không phải cài vào từng sheet thì có được không?

Private Sub Workbook_Open()
With Sheet2
.EnableOutlining = True
.Protect Password:="123", Contents:=True, UserInterfaceOnly:=True
End With
End Sub

Em cảm ơn mọi người nhiều lắm.

vova2209 · 28/9/17

Thưa thầy! em làm 1 code copy như này bị sai ở đâu, và có phải khai báo thêm biến gì nữa không. Và cách viết khác như thủ tục em làm không ạ:
Sub MaBB_KL()
Sheets("KLL-K95").Select
Range("J9").Copy

Sheets("KL-L1").Select
Range("J8").PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False
End Sub

chisinhvnn · 28/9/17

vova2209 đã viết:
Thưa thầy! em làm 1 code copy như này bị sai ở đâu, và có phải khai báo thêm biến gì nữa không. Và cách viết khác như thủ tục em làm không ạ:
Sub MaBB_KL()
Sheets("KLL-K95").Select
Range("J9").Copy

Sheets("KL-L1").Select
Range("J8").PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False
End Sub

http://www.giaiphapexcel.com/diendan/threads/vấn-đề-copy-trong-vba.29457/
Xem ở đây bạn

vova2209 · 29/9/17

chisinhvnn đã viết:
http://www.giaiphapexcel.com/diendan/threads/vấn-đề-copy-trong-vba.29457/
Xem ở đây bạn

ok thanks!

vova2209 · 29/9/17

Thưa thầy: Code của em dùng vòng For đang cho chạy từ 1~5 tách thành 5 sheet: giờ em muốn khi bấm vào code nó sẽ hỏi là muốn copy thành bao nhiêu sheets thì làm như nào ạ:
Sub Macro1()
Dim ShName As String
Dim i As Long
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Activate
For i = 1 To 5
ShName = ("KL.D") & i
ws.Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Name = ShName
Next i
End Sub

PacificPR · 29/9/17

vova2209 đã viết:
Thưa thầy: Code của em dùng vòng For đang cho chạy từ 1~5 tách thành 5 sheet: giờ em muốn khi bấm vào code nó sẽ hỏi là muốn copy thành bao nhiêu sheets thì làm như nào ạ:
Sub Macro1()
Dim ShName As String
Dim i As Long
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Activate
For i = 1 To 5
ShName = ("KL.D") & i
ws.Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Name = ShName
Next i
End Sub

Em xen ngang 1 tí nha
1. Nếu muốn xuất từ số ... đến số ... bạn làm 1 Form như kiểu máy in ấy .... Xong gắn vào vòng lặp
2. Nếu Sheet có công thức thì Code trên sẽ có vấn đè không lấy được số "chêt"

vova2209 · 29/9/17

PacificPR đã viết:
Em xen ngang 1 tí nha
1. Nếu muốn xuất từ số ... đến số ... bạn làm 1 Form như kiểu máy in ấy .... Xong gắn vào vòng lặp
2. Nếu Sheet có công thức thì Code trên sẽ có vấn đè không lấy được số "chêt"

Em chỉ muốn copy số lượng sheet thôi ạ! Code sẽ phải sửa như nào ạ

PacificPR · 29/9/17

vova2209 đã viết:
Em chỉ muốn copy số lượng sheet thôi ạ! Code sẽ phải sửa như nào ạ

Vậy thì em không biết dâu. Cài này em chưa học và chưa từng làm

HieuCD · 29/9/17

PacificPR đã viết:
Vậy thì em không biết dâu. Cài này em chưa học và chưa từng làm

xem phần Help: InputBox Function

vova2209 · 29/9/17

HieuCD đã viết:
xem phần Help: InputBox Function

vâng cảm ơn anh!

trinhvinhtai · 30/9/17

trinhvinhtai đã viết:
Public Sub GPE()
Dim Arr(), i As Integer, vArr()
Arr = Range("b2:m" & Range("m65000").End(xlUp).Row).Value
ReDim vArr(1 To UBound(Arr), 1 To 1)
For i = 1 To UBound(Arr)
vArr(i, 1) = Application.Evaluate(Arr(i, 1) & "/" & Arr(i, 12) & "*" & Arr(i, 2)) 'chia 8: 8 day so co dinh trong code luôn'
Next i
Range("d2").Resize(UBound(Arr)) = vArr

End Sub

chao e muốn thêm code này vArr(i, 1) = Application.Evaluate(Arr(i, 1) & "/" & Arr(i, 12) & "*" & Arr(i, 2))/8 số 8 tô màu đó là cố định trong code luôn.

câu @: e mun xai code hàm if cho e xin code hàm if với.

mong mọi người giúp đỡ.

GIUP MÌNH VỚI

sondaubac · 4/10/17

Nhờ các bạn kiểm tra dùm mình bị lỗi chỗ nào mà khi sử dụng sự kiện worksheet_change trong sheet XuatDL ở các Cells trong cột B thì nó tra cứu được theo mảng nhưng mà mất giá trị đầu tiên

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Dulieu, Ketqua, I As Long, K As Long, Ivl As Long, Inc As Long, Imay As Long
    Dim VL As String, Nc As String, May As String, LaMa As Long
    Dim Ma As String, Mahieu As String
VL = "V" & ChrW$(7853) & "t li" & ChrW$(7879) & "u"
Nc = "Nh" & ChrW$(226) & "n c" & ChrW$(244) & "ng"
May = "M" & ChrW$(225) & "y"
On Error Resume Next
If Not Intersect(Target, [B7:B10000]) Is Nothing Then
    If Target.Count = 1 Then
        Mahieu = Sheets("XuatDL").Range("B" & Target.Row)
        With Sheets("CSDL DM")
            Dulieu = .Range("B5", .Range("B65535").End(3)).Resize(, 6)                  ' Chon vung DL dinh muc tu o B5 den G...
        End With
        ReDim Ketqua(1 To UBound(Dulieu), 1 To 6)
     
        For I = 1 To UBound(Dulieu)
     
            Ma = Dulieu(I, 1)           ' Ma = Ma hieu cong viec o cot 1 cua Mang DuLieu
         
            If Ma = Mahieu Then
         
                K = K + 1
             
                If K = 1 Then               ' Chay dong dau tien, tim ten CV, DVT, KL = 1
             
                    Ketqua(K, 2) = "=VLOOKUP(RC[-2],'CSDL tenCV'!R5C2:R1800C4,2,0)"     ' Tim ten CV trong CSDL tenCV
                    Ketqua(K, 3) = "=VLOOKUP(RC[-3],'CSDL tenCV'!R5C2:R1800C4,3,0)"     ' Tim DVT cua cong viec trong CSDL tenCV
                    Ketqua(K, 4) = 1                                                    ' Gan Khoi luong = 1
                End If
             
             
                If K > 1 Then               ' Chay dong thu 2, xuat mang KET QUA tu mang Du Lieu
                 
                    If Dulieu(I, 4) = VL Then                                        ' Neu cot so 4 cua sheet CSDL DM la VAT LIEU thi lam ....
                        Ivl = Ivl + 1
                        If Ivl = 1 Then
                            Ketqua(K, 2) = ChrW(97) & "). " & VL                        ' Danh chu a). Vat Lieu
                            K = K + 1
                        End If
                        Ketqua(K, 1) = Dulieu(I, 2): Ketqua(K, 2) = Dulieu(I, 5): Ketqua(K, 5) = Dulieu(I, 3)
                    End If
                 
                    If Dulieu(I, 4) = Nc Then
                        Inc = Inc + 1
                        If Inc = 1 Then
                            Ketqua(K, 2) = ChrW(98) & "). " & Nc                        ' Danh chu b). Nhan Cong
                            K = K + 1
                        End If
                        Ketqua(K, 1) = Dulieu(I, 2):  Ketqua(K, 2) = Dulieu(I, 5): Ketqua(K, 5) = Dulieu(I, 3)
                    End If
                 
                    If Dulieu(I, 4) = May Then
                        Imay = Imay + 1
                        If Imay = 1 Then
                            Ketqua(K, 2) = ChrW(99) & "). " & May                       ' Danh chu c). May
                            K = K + 1
                        End If
                        Ketqua(K, 1) = Dulieu(I, 2): Ketqua(K, 2) = Dulieu(I, 5): Ketqua(K, 5) = Dulieu(I, 3)
                    End If
                End If
            End If
        Next I
        If K Then
            Target.Offset(, 1).Resize(K, 5) = Ketqua
            Range("A" & Target.Row & ":G" & Target.Row).Resize(K).Borders.LineStyle = 1
            Range("A" & Target.Row & ":G" & Target.Row).Resize(K).Borders(xlInsideHorizontal).Weight = xlHairline
        Else
            MsgBox "Khong tim thay"
        End If
    End If
End If
End Sub

Ba Tê · 5/10/17

sondaubac đã viết:
Nhờ các bạn kiểm tra dùm mình bị lỗi chỗ nào mà khi sử dụng sự kiện worksheet_change trong sheet XuatDL ở các Cells trong cột B thì nó tra cứu được theo mảng nhưng mà mất giá trị đầu tiên
..........................

Bạn xem thử file này coi sao.

sondaubac · 5/10/17

Mã:

Private Sub cmdNhapLieu_Click()
Dim ApMH As Range
Dim x As Integer

    Set ApMH = Sheet1.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)   ' Chon o bat dau dien du lieu
   
    For x = 0 To Me.LBox_DATAtenCV.ListCount - 1                    ' LBox_DATAtenCV la ten cua list box ma chung ta chon trong form
                                                                    ' Cho x chay tu dong so 0 den dong so cuoi cung cua ListBox -1 (tuc la cho i chay tu dong dau den dong cuoi List Box)
                                                                   
        If Me.LBox_DATAtenCV.Selected(x) Then                       ' Neu lua chon dong thu x+1 thi
       
            ApMH = Me.LBox_DATAtenCV.List(x)                        ' Gan ApMh la vung du lieu cua dong thu x+1
            ApMH.Offset(0, 0) = Me.LBox_DATAtenCV.List(x, 1)        ' Gan ApMh dong 1 cot 1 là vung du lieu LIST BOX dong x+1 cot 1
            ApMH.Offset(0, 1) = Me.LBox_DATAtenCV.List(x, 2)        ' Gan ApMh dong 1 cot 2 là vung du lieu LIST BOX dong x+1 cot 2
            ApMH.Offset(0, 2) = Me.LBox_DATAtenCV.List(x, 3)        ' Gan ApMh dong 1 cot 3 là vung du lieu LIST BOX dong x+1 cot 3

            Set ApMH = ApMH.Offset(1, 0)                            ' Cho ApMh di chuyen xuong 1 dong
        End If
    Next x
    For x = 0 To Me.LBox_DATAtenCV.ListCount - 1
        If Me.LBox_DATAtenCV.Selected(x) Then Me.LBox_DATAtenCV.Selected(x) = False
    Next x
    Unload formTraMH
End Sub

Check dùm mình cái Form nhập dữ liệu bên sheet KHOI LUONG với, sao nó lại không chạy được nhỉ?
Nhờ các bạn chỉ giúp mình lỗi sai chỗ nào với

chisinhvnn · 5/10/17

Mã:

Public Sub tinhtien2() 'GPE
Dim sArr(), dArr(), I As Long, R As Long, tong As Double
lr = Sheet3.Cells(Rows.Count, "B").End(xlUp).Row
sArr = Sheet3.Range("A6:F" & lr).Value
R = UBound(sArr)
Application.ScreenUpdating = False
ReDim dArr(1 To R, 1 To 1)
For I = R To 1 Step -1
    If sArr(I, 1) = Empty Then
        dArr(I, 1) = Application.WorksheetFunction.IfError(sArr(I, 4) * sArr(I, 5) * sArr(I, 6), 0)
          
   
        tong = tong + dArr(I, 1)
    Else
        dArr(I, 1) = Application.WorksheetFunction.Round(tong, -3): tong = 0
  
    End If
Next I
Sheet3.Range("G5") = "=Round(SUM(R[1]C:R[" & R & "]C)/2,-3)"
Sheet3.Range("G6").Resize(UBound(sArr)) = dArr
Application.ScreenUpdating = True
End Sub

Mình dùng iferror để bẩy lỗi các cột có giá trị là chữ (hoặc trống) nhưng khi chạy code vẫn bị báo lỗi.

Mã:

  "dArr(I, 1) = Application.WorksheetFunction.IfError(sArr(I, 4) * sArr(I, 5) * sArr(I, 6), 0)"

Nhờ GPE giúp đỡ mình với.

hpkhuong · 5/10/17

chisinhvnn đã viết:
Nhờ GPE giúp đỡ mình với.

Chi khổ vậy bạn. Sao không viết công thức thắng vào sheet. chỉ là 3 cột nhân với nhau thôi mà...:

Horse · 5/10/17

chisinhvnn đã viết:

Mã:

Public Sub tinhtien2() 'GPE
Dim sArr(), dArr(), I As Long, R As Long, tong As Double
lr = Sheet3.Cells(Rows.Count, "B").End(xlUp).Row
sArr = Sheet3.Range("A6:F" & lr).Value
R = UBound(sArr)
Application.ScreenUpdating = False
ReDim dArr(1 To R, 1 To 1)
For I = R To 1 Step -1
    If sArr(I, 1) = Empty Then
        dArr(I, 1) = Application.WorksheetFunction.IfError(sArr(I, 4) * sArr(I, 5) * sArr(I, 6), 0)
         
  
        tong = tong + dArr(I, 1)
    Else
        dArr(I, 1) = Application.WorksheetFunction.Round(tong, -3): tong = 0
 
    End If
Next I
Sheet3.Range("G5") = "=Round(SUM(R[1]C:R[" & R & "]C)/2,-3)"
Sheet3.Range("G6").Resize(UBound(sArr)) = dArr
Application.ScreenUpdating = True
End Sub

Mình dùng iferror để bẩy lỗi các cột có giá trị là chữ (hoặc trống) nhưng khi chạy code vẫn bị báo lỗi.

Mã:

  "dArr(I, 1) = Application.WorksheetFunction.IfError(sArr(I, 4) * sArr(I, 5) * sArr(I, 6), 0)"

Nhờ GPE giúp đỡ mình với.

Anh thử sửa lại như thế này xem

HTML:

Public Sub tinhtien2()
    Dim sArr(), dArr(), I As Long, R As Long, tong As Double
On Error Resume Next
lr = Sheet3.Cells(Rows.Count, "B").End(xlUp).Row
sArr = Sheet3.Range("A6:F" & lr).Value
R = UBound(sArr)
Application.ScreenUpdating = False
ReDim dArr(1 To R, 1 To 1)
For I = R To 1 Step -1
    If sArr(I, 1) = Empty Then
        dArr(I, 1) = Application.WorksheetFunction.Product(sArr(I, 4), sArr(I, 5), sArr(I, 6))
        tong = tong + dArr(I, 1)
    Else
        dArr(I, 1) = Application.WorksheetFunction.Round(tong, -3): tong = 0
    End If
Next I
Sheet3.Range("G5") = "=Round(SUM(R[1]C:R[" & R & "]C)/2,-3)"
Sheet3.Range("G6").Resize(UBound(sArr)) = dArr
Application.ScreenUpdating = True
End Sub

chisinhvnn · 5/10/17

hpkhuong đã viết:
Chi khổ vậy bạn. Sao không viết công thức thắng vào sheet. chỉ là 3 cột nhân với nhau thôi mà...:

Cộng từng mục nữa mà anh

chisinhvnn · 5/10/17

Horse đã viết:

Anh thử sửa lại như thế này xem

HTML:

Public Sub tinhtien2()
    Dim sArr(), dArr(), I As Long, R As Long, tong As Double
On Error Resume Next
lr = Sheet3.Cells(Rows.Count, "B").End(xlUp).Row
sArr = Sheet3.Range("A6:F" & lr).Value
R = UBound(sArr)
Application.ScreenUpdating = False
ReDim dArr(1 To R, 1 To 1)
For I = R To 1 Step -1
    If sArr(I, 1) = Empty Then
        dArr(I, 1) = Application.WorksheetFunction.Product(sArr(I, 4), sArr(I, 5), sArr(I, 6))
        tong = tong + dArr(I, 1)
    Else
        dArr(I, 1) = Application.WorksheetFunction.Round(tong, -3): tong = 0
    End If
Next I
Sheet3.Range("G5") = "=Round(SUM(R[1]C:R[" & R & "]C)/2,-3)"
Sheet3.Range("G6").Resize(UBound(sArr)) = dArr
Application.ScreenUpdating = True
End Sub

Cảm ơn bạn.

Hoang2013 · 5/10/17

Nếu là mình thì xài IsNumeric(); Tuy dài nhưng chắc không báo lỗi.

Còn vẫn thích Application thì thử với hàm N() xem sao.

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

Huyền thoại GPE

Thành viên mới

File đính kèm

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

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

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

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

Thành viên mới

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

Thành viên mới

Chuyên gia GPE

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

Thành viên hoạt động

Thành viên hoạt động

File đính kèm

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

File đính kèm

Thành viên hoạt động

File đính kèm

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

File đính kèm

######

Thành viên mới

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

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

Thành viên gắn bó

Facebook

Group