Chuyển file công thức excel thành code VBA (1 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
L

LightStar252

Thành viên hoạt động
Tham gia
9/7/16
Bài viết
112
Được thích
10
Ai giúp mình chuyển mấy công thức excel này thành code VBA cho đỡ nặng với ạ, hoặc là giúp mình code VBA tìm kiếm và tổng hợp dữ liệu thay thế các công thức excel cũng được ạ!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
LightStar252 đã viết:
Ai giúp mình chuyển mấy công thức excel này thành code VBA cho đỡ nặng với ạ, hoặc là giúp mình code VBA tìm kiếm và tổng hợp dữ liệu thay thế các công thức excel cũng được ạ!
Nhấp chuột vào đây để mở rộng...
Trong File có code
Mã: 
Sub baocaodaumaythang()
'
' baocaodaumaythang Macro
'

'
' so may
' =IFERROR(INDEX('BCHN.T1.2017.xls'!SM,MATCH(0,COUNTIF(C$9:$C11,'BCHN.T1.2017 .xls'!SM),0)),"")
    Range("C12").Select
    Selection.FormulaArray = _
        "=IFERROR(INDEX('BCHN.T1.2017.xls'!SM,MATCH(0,COUNTIF(R9C:R[-1]C3,'BCHN.T1.2017.xls'!SM),0)),"""")"
' loai may
' =IFERROR((VLOOKUP(C12,CSDL!$B$10:$C$275,2,0))," ")
    Range("B12").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR((VLOOKUP(RC[1],CSDL!R10C2:R275C3,2,0)),"" "")"
' dm chieu cao
' =IFERROR((VLOOKUP(C12,CSDL!$B$10:$H$275,5,0))," ")
    Range("D12").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR((VLOOKUP(RC[-1],CSDL!R10C2:R275C8,5,0)),"" "")"
' dm gio
' =IFERROR((VLOOKUP(C12,CSDL!$B$10:$H$275,6,0)),"")
    Range("E12").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR((VLOOKUP(RC[-2],CSDL!R10C2:R275C8,6,0)),"""")"
' tong gio
' =IF(C12<>"",SUMIF(BCHN!$D$10:$D$3139,C12,BCHN!$I$10:$I$3139),"")
    Range("F12").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-3]<>"""",SUMIF(BCHN!R10C4:R3139C4,RC[-3],BCHN!R10C9:R3139C9),"""")"
' tong dau
' =IF(C12<>"",SUMIF(BCHN!$D$10:$D$3139,C12,BCHN!$J$10:$J$3139),"")
    Range("G12").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(RC[-4]<>"""",SUMIF(BCHN!R10C4:R3139C4,RC[-4],BCHN!R10C10:R3139C10),"""")"
' ton dau dau
' =IF(D12="K do dc",0,IFERROR(J12*D12,""))
    Range("H12").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-4]=""K do dc"",0,IFERROR(RC[2]*RC[-4],""""))"
' ton dau cuoi
' =IF(D12="K do dc",0,IFERROR(K12*D12,""))
    Range("I12").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-5]=""K do dc"",0,IFERROR(RC[2]*RC[-5],""""))"
' chieu cao dau dau
' =IFERROR(OFFSET(INDEX('BCHN.T1.2017.xls'!data, MATCH(C12&$A$6, 'BCHN.T1.2017.xls'!SM&Ngay, 0), MATCH($J$9,BCHN!$C$8:$O$8,0)),2,0),"")
    Range("J12").Select
    Selection.FormulaArray = _
        "=IFERROR(OFFSET(INDEX('BCHN.T1.2017.xls'!data, MATCH(RC[-7]&R6C1, 'BCHN.T1.2017.xls'!SM&Ngay, 0), MATCH(R9C10,BCHN!R8C3:R8C15,0)),2,0),"""")"
' chieu cao dau cuoi
' =IFERROR((OFFSET(INDEX('BCHN.T1.2017 .xls'!data, MATCH(C12&$A$7, 'BCHN.T1.2017.xls'!SM&Ngay, 0), MATCH($K$9,BCHN!$C$8:$Q$8, 0)),2,0)),"")
    Range("K12").Select
    Selection.FormulaArray = _
        "=IFERROR((OFFSET(INDEX('BCHN.T1.2017.xls'!data, MATCH(RC[-8]&R7C1, 'BCHN.T1.2017.xls'!SM&Ngay, 0), MATCH(R9C11,BCHN!R8C3:R8C17, 0)),2,0)),"""")"

' dau theo dinh muc
' =IFERROR(F12*E12,"")
    Range("L12").Select
    ActiveCell.FormulaR1C1 = "=IFERROR(RC[-6]*RC[-7],"""")"
' ton dau
' =IFERROR(L12-(G12+H12-I12),"")
    Range("M12").Select
    ActiveCell.FormulaR1C1 = "=IFERROR(RC[-1]-(RC[-6]+RC[-5]-RC[-4]),"""")"
' tieu thu dau trung binh
' =IFERROR(IF(F12=0,"",(H12+G12-I12)/F12),"")
    Range("N12").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(IF(RC[-8]=0,"""",(RC[-6]+RC[-7]-RC[-5])/RC[-8]),"""")"
' chenh lech gio thuc te
' =IFERROR(IF(F12=0,"",E12-N12),"")
    Range("O12").Select
    ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-9]=0,"""",RC[-10]-RC[-1]),"""")"
' cong truong
' =IFERROR((VLOOKUP(C12,LK!$C$12:$P$128,14,0))," ")
    Range("P12").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR((VLOOKUP(RC[-13],LK!R12C3:R128C16,14,0)),"" "")"
' =1
    Range("A12").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A13").Select
' so thu tu
' =IF(C13<>"",A12+1,"")
    ActiveCell.FormulaR1C1 = "=IF(RC[2]<>"""",R[-1]C+1,"""")"
    Range("B12:P12").Select
    Selection.AutoFill Destination:=Range("B12:P128"), Type:=xlFillDefault
    Range("B12:P128").Select
    ActiveWindow.SmallScroll Down:=-129
    Range("A13").Select
    Selection.AutoFill Destination:=Range("A13:A128"), Type:=xlFillDefault
    Range("A13:A128").Select
    ActiveWindow.SmallScroll Down:=-123
    Range("A12:P128").Select
    ActiveWindow.SmallScroll Down:=-120
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C9:C10").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "S? máy"
    Range("C11").Select
' ham tinh tong ton dau (du tru dung sau): k lien quan lam =SUMIFS(BCHN!$J$10:$J$3264,'BCHN.T1.2017 .xls'!Ngay,"<="&$A$7,'BCHN.T1.2017 .xls'!SM,C12)-SUMIFS(BCHN!$Q$10:$Q$3264,'BCHN.T1.2017 .xls'!Ngay,"<="&$A$7,SM,C12)

End Sub
Mà cũng khóa làm gì vậy trời
 
Upvote 0
Upvote 0
Có cách nào khác chỉ dùng code VBA thôi chứ không phải dùng công thức Excel, rồi lại chuyển từ công thức excel sang code như thế này k mn
 
Upvote 0
PacificPR đã viết:
1 tháng của bạn có 30 ngày chẳng hạn thì file BCTH cột 10 và cột 11 tính như thế nào
Nhấp chuột vào đây để mở rộng...
Chiều cao dầu đó tìm kiếm theo 2 điều kiện ngày tháng và cột "chiều cao dầu đầu" hay "chiều cao dầu cuối" ở sheet BCHN đó. Còn muốn tìm chiều cao ngày nào thì sửa 2 ô A6 và A7 ở sheet BCTH đấy
 
Upvote 0
LightStar252 đã viết:
Chiều cao dầu đó tìm kiếm theo 2 điều kiện ngày tháng và cột "chiều cao dầu đầu" hay "chiều cao dầu cuối" ở sheet BCHN đó. Còn muốn tìm chiều cao ngày nào thì sửa 2 ô A6 và A7 ở sheet BCTH đấy
Nhấp chuột vào đây để mở rộng...
Bạn thử xem file xem có đúng không
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
quocthan92 đã viết:
Cao thu giai thich doan code nay de minh tham khao nhe
Nhấp chuột vào đây để mở rộng...
Mã: 
Public Sub Tonghop()
    Dim sArr(), tArr(), dArr(), I As Long, K As Long, Thang As Long
    Dim Dic As Object, Tem As String
Set Dic = CreateObject("Scripting.Dictionary") ' tao mot doi tung DIC
Thang = Month(Sheets("BCTH").Range("G6")) 'Lay gia tri Thang tai G6 gan vao bien Thang
With Sheets("CSDL")
    tArr = .Range(.Range("B11"), .Range("B65535").End(3)).Resize(, 6).Value ' chon Vung tu B1 den , co du lieu cuoi cung
End With
For I = 1 To UBound(tArr, 1) ' cho bien I chay tu B4 cho den cuoi cung co chua du lieu
    Dic.Item(tArr(I, 1)) = I ' Thiet lap gia tri Item bang I
Next I
With Sheets("BCHN")
    sArr = .Range(.Range("B10"), .Range("B65535").End(3)).Resize(, 15).Value ' chon vung du lieu B10 den cot P co chua du lieu cuoi cung
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 15) ' Xac dinh lai kich co cua mang dArr
For I = 1 To UBound(sArr, 1)                ' Cho Bien I chay tu 1 cho den het trong cot B
    If Month(sArr(I, 1)) = Thang Then       ' Neu tung dong, co thang = gia tri thang da khai bao ben sheet BCTH thi
        Tem = sArr(I, 3)                    ' Them so may vao bien Tem
        If Not Dic.Exists(Tem) Then         ' Kiem tra trong Dic co so may chua?
            K = K + 1                       ' Tang bien K len
            Dic.Add Tem, K                  ' Chua co thi Add vao, Key la Tem, Items la K
            dArr(K, 1) = K                  ' Them vao mang darr STT K,
            dArr(K, 2) = sArr(I, 2)         'Them Loai may vao mang
            dArr(K, 3) = Tem                ' Them So May vao mang
            dArr(K, 4) = tArr(Dic.Item(Tem), 5) 'Them Dinh Muc theo chieu cao vao mang
            dArr(K, 5) = tArr(Dic.Item(Tem), 6) ' Them Dinh Muc theo So Lit vao mang
            dArr(K, 6) = sArr(I, 8)             'Them Gio lam vao mang
            dArr(K, 7) = sArr(I, 9)             'Them Dau Nhan vao Mang
            dArr(K, 10) = sArr(I, 6)            ' Them Chieu cao dau dau
            dArr(K, 11) = ""                    ' Trong
        Else
            dArr(Dic.Item(Tem), 6) = dArr(Dic.Item(Tem), 6) + sArr(I, 8)
            dArr(Dic.Item(Tem), 7) = dArr(Dic.Item(Tem), 7) + sArr(I, 9)
            dArr(Dic.Item(Tem), 11) = sArr(I, 7)
            dArr(K, 8) = dArr(K, 4) * dArr(K, 10): dArr(K, 9) = dArr(K, 4) * dArr(K, 11)
            dArr(K, 12) = dArr(K, 5) * dArr(K, 6)
            dArr(K, 13) = dArr(K, 12) - (dArr(K, 7) + dArr(K, 8) - dArr(K, 9))
            dArr(K, 14) = (dArr(K, 8) + dArr(K, 7) - dArr(K, 9)) / dArr(K, 6)
            dArr(K, 15) = dArr(K, 5) - dArr(K, 14)
        End If
    End If
Next I
With Sheets("BCTH")                                                     ' chon Sheet
    .Range("A12:P" & .Range("A65535").End(3).Row + 1).ClearContents     ' Xac dinh vung du lieu can xoa
    .Range("A12").Resize(K, 15) = dArr                                  ' Xac dinh Vung du lieu can dan Mang xuong bang tinh
End With
Set Dic = Nothing
End Sub

Hy vọng giúp đỡ được bạn./
 
Upvote 0
Minh hiểu rồi, thank so much!
P/s: Mình có 1 câu hỏi them là muốn viết code copy dữ liệu "A1:A100" row lẽ thì paste cột "B1:B50" chẳn thì "C1:C50"
 
Upvote 0
quocthan92 đã viết:
Minh hiểu rồi, thank so much!
P/s: Mình có 1 câu hỏi them là muốn viết code copy dữ liệu "A1:A100" row lẽ thì paste cột "B1:B50" chẳn thì "C1:C50"
Nhấp chuột vào đây để mở rộng...
Sao đã "lẽ thì " rồi còn "chẳn thì" :D. Bạn cần diễn đạt rõ ràng thêm .......
Bạn chú ý không dùng mấy từ thank so much! này
 
Upvote 0
Upvote 0
PacificPR đã viết:
Ồ may nhờ anh em mới hiểu bạn ấy nói gì Lẽ chẳn có nghĩa là chẵn lẻ. (Có nghĩa là Copy từ A1 đến A100, nếu dòng chẵn thì điền vào cột B, dòng lẻ điền vào cột C)
Tiếng việt phong phú qua anh ạ :eek:
Nhấp chuột vào đây để mở rộng...
Đây không phải là trường hợp phong phú. Đây là vấn đề học tiếng Việt.
Chê ngọng cái chạy mất dép luôn. Thất kha khá trường hợp, bị chê cái... khoảng 1 phút sau khi đọc bài thì nick tối thui. o_O
 
Upvote 0
Upvote 0
quocthan92 đã viết:
Bạn làm mình rối quá
Nhấp chuột vào đây để mở rộng...
Có gì đâu mà rối.
Minh hiểu rồi, thank so much!
P/s: Mình có 1 câu hỏi them là muốn viết code copy dữ liệu "A1:A100" row lẽ thì paste cột "B1:B50" chẳn thì "C1:C50"
Nhấp chuột vào đây để mở rộng...
Bạn viết tiếng Anh được (hổng biết trúng hông) nhưng tiếng Việt thì sai bét nên mọi người ngạc nhiên thôi.
Số chẵn, số lẻ. Bạn viết ...lẽ... chẳn thì...
Nên viết chuẩn tiếng Việt mới đúng là người Việt. Giỏi tiếng nước ngoài chỉ để trao đổi với người nước ngoài.
 
Upvote 0
PacificPR đã viết:
Bạn thử xem file xem có đúng không
Nhấp chuột vào đây để mở rộng...
Bạn ơi, giúp mình thêm một tí đc k. Mình muốn thêm đoạn code lấy tên công trường cuối tháng ở cột 0 sheet "BCHN" qua cột P sheet "BCTH" ấy, tháng có 30 ngày thì lấy tên công trường ngày 30, tháng 31 thì lấy tên công trường ngày 31... Mình mò mãi k đc (@$%@
 
Upvote 0
LightStar252 đã viết:
Bạn ơi, giúp mình thêm một tí đc k. Mình muốn thêm đoạn code lấy tên công trường cuối tháng ở cột 0 sheet "BCHN" qua cột P sheet "BCTH" ấy, tháng có 30 ngày thì lấy tên công trường ngày 30, tháng 31 thì lấy tên công trường ngày 31... Mình mò mãi k đc (@$%@
Nhấp chuột vào đây để mở rộng...
bạn thay Code cũ bằng cái này thử:
Mã: 
Sub Tonghop()
    Dim sArr(), tArr(), dArr(), I As Long, K As Long, Thang As Long
    Dim Dic As Object, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Thang = Month(Sheets("BCTH").Range("G6"))
With Sheets("CSDL")
    tArr = .Range(.Range("B11"), .Range("B65535").End(3)).Resize(, 6).Value
End With
For I = 1 To UBound(tArr, 1)
    Dic.Item(tArr(I, 1)) = I
Next I
With Sheets("BCHN")
    sArr = .Range(.Range("B10"), .Range("B65535").End(3)).Resize(, 15).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 16)
For I = 1 To UBound(sArr, 1)
    If Month(sArr(I, 1)) = Thang Then
        Tem = sArr(I, 3)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Add Tem, K
            dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 2): dArr(K, 3) = Tem
            dArr(K, 4) = tArr(Dic.Item(Tem), 5): dArr(K, 5) = tArr(Dic.Item(Tem), 6)
            dArr(K, 6) = sArr(I, 8): dArr(K, 7) = sArr(I, 9)
            dArr(K, 10) = sArr(I, 6)
            dArr(K, 16) = sArr(I, 14)
        Else
            dArr(Dic.Item(Tem), 6) = dArr(Dic.Item(Tem), 6) + sArr(I, 8)
            dArr(Dic.Item(Tem), 7) = dArr(Dic.Item(Tem), 7) + sArr(I, 9)
            dArr(Dic.Item(Tem), 16) = sArr(I, 14)
            dArr(Dic.Item(Tem), 11) = sArr(I, 7)
            dArr(K, 8) = dArr(K, 4) * dArr(K, 10): dArr(K, 9) = dArr(K, 4) * dArr(K, 11)
            dArr(K, 12) = dArr(K, 5) * dArr(K, 6)
            dArr(K, 13) = dArr(K, 12) - (dArr(K, 7) + dArr(K, 8) - dArr(K, 9))
            dArr(K, 14) = (dArr(K, 8) + dArr(K, 7) - dArr(K, 9)) / dArr(K, 6)
            dArr(K, 15) = dArr(K, 5) - dArr(K, 14)
        End If
    End If
Next I
With Sheets("BCTH")
    .Range("A12:P" & .Range("A65535").End(3).Row + 1).ClearContents
    .Range("A12").Resize(K, 16) = dArr
End With
Set Dic = Nothing
End Sub
 
Upvote 0
PacificPR đã viết:
bạn thay Code cũ bằng cái này thử:
Mã: 
Sub Tonghop()
    Dim sArr(), tArr(), dArr(), I As Long, K As Long, Thang As Long
    Dim Dic As Object, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Thang = Month(Sheets("BCTH").Range("G6"))
With Sheets("CSDL")
    tArr = .Range(.Range("B11"), .Range("B65535").End(3)).Resize(, 6).Value
End With
For I = 1 To UBound(tArr, 1)
    Dic.Item(tArr(I, 1)) = I
Next I
With Sheets("BCHN")
    sArr = .Range(.Range("B10"), .Range("B65535").End(3)).Resize(, 15).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 16)
For I = 1 To UBound(sArr, 1)
    If Month(sArr(I, 1)) = Thang Then
        Tem = sArr(I, 3)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Add Tem, K
            dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 2): dArr(K, 3) = Tem
            dArr(K, 4) = tArr(Dic.Item(Tem), 5): dArr(K, 5) = tArr(Dic.Item(Tem), 6)
            dArr(K, 6) = sArr(I, 8): dArr(K, 7) = sArr(I, 9)
            dArr(K, 10) = sArr(I, 6)
            dArr(K, 16) = sArr(I, 14)
        Else
            dArr(Dic.Item(Tem), 6) = dArr(Dic.Item(Tem), 6) + sArr(I, 8)
            dArr(Dic.Item(Tem), 7) = dArr(Dic.Item(Tem), 7) + sArr(I, 9)
            dArr(Dic.Item(Tem), 16) = sArr(I, 14)
            dArr(Dic.Item(Tem), 11) = sArr(I, 7)
            dArr(K, 8) = dArr(K, 4) * dArr(K, 10): dArr(K, 9) = dArr(K, 4) * dArr(K, 11)
            dArr(K, 12) = dArr(K, 5) * dArr(K, 6)
            dArr(K, 13) = dArr(K, 12) - (dArr(K, 7) + dArr(K, 8) - dArr(K, 9))
            dArr(K, 14) = (dArr(K, 8) + dArr(K, 7) - dArr(K, 9)) / dArr(K, 6)
            dArr(K, 15) = dArr(K, 5) - dArr(K, 14)
        End If
    End If
Next I
With Sheets("BCTH")
    .Range("A12:P" & .Range("A65535").End(3).Row + 1).ClearContents
    .Range("A12").Resize(K, 16) = dArr
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
PacificPR đã viết:
bạn thay Code cũ bằng cái này thử:
Mã: 
Sub Tonghop()
    Dim sArr(), tArr(), dArr(), I As Long, K As Long, Thang As Long
    Dim Dic As Object, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Thang = Month(Sheets("BCTH").Range("G6"))
With Sheets("CSDL")
    tArr = .Range(.Range("B11"), .Range("B65535").End(3)).Resize(, 6).Value
End With
For I = 1 To UBound(tArr, 1)
    Dic.Item(tArr(I, 1)) = I
Next I
With Sheets("BCHN")
    sArr = .Range(.Range("B10"), .Range("B65535").End(3)).Resize(, 15).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 16)
For I = 1 To UBound(sArr, 1)
    If Month(sArr(I, 1)) = Thang Then
        Tem = sArr(I, 3)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Add Tem, K
            dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 2): dArr(K, 3) = Tem
            dArr(K, 4) = tArr(Dic.Item(Tem), 5): dArr(K, 5) = tArr(Dic.Item(Tem), 6)
            dArr(K, 6) = sArr(I, 8): dArr(K, 7) = sArr(I, 9)
            dArr(K, 10) = sArr(I, 6)
            dArr(K, 16) = sArr(I, 14)
        Else
            dArr(Dic.Item(Tem), 6) = dArr(Dic.Item(Tem), 6) + sArr(I, 8)
            dArr(Dic.Item(Tem), 7) = dArr(Dic.Item(Tem), 7) + sArr(I, 9)
            dArr(Dic.Item(Tem), 16) = sArr(I, 14)
            dArr(Dic.Item(Tem), 11) = sArr(I, 7)
            dArr(K, 8) = dArr(K, 4) * dArr(K, 10): dArr(K, 9) = dArr(K, 4) * dArr(K, 11)
            dArr(K, 12) = dArr(K, 5) * dArr(K, 6)
            dArr(K, 13) = dArr(K, 12) - (dArr(K, 7) + dArr(K, 8) - dArr(K, 9))
            dArr(K, 14) = (dArr(K, 8) + dArr(K, 7) - dArr(K, 9)) / dArr(K, 6)
            dArr(K, 15) = dArr(K, 5) - dArr(K, 14)
        End If
    End If
Next I
With Sheets("BCTH")
    .Range("A12:P" & .Range("A65535").End(3).Row + 1).ClearContents
    .Range("A12").Resize(K, 16) = dArr
End With
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Giúp mình thêm cái sheet "Âm dầu" này nữa được k bạn. Thanh bạn :))
 

File đính kèm

Upvote 0
LightStar252 đã viết:
Giúp mình thêm cái sheet "Âm dầu" này nữa được k bạn. Thanh bạn :))
Nhấp chuột vào đây để mở rộng...
Code lấy dầu Âm, Âm dầu đây
Mã: 
Sub DauAm()
    Dim sArr, dArr, tArr, I As Long, K As Long
    Dim Dic As Object, tem As String
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheets("CSDL")
        tArr = .Range(.Range("C11"), .Range("C65535").End(3)).Resize(, 8).Value
    End With
    For I = 1 To UBound(tArr, 1)
        Dic.Item(tArr(I, 1)) = I
    Next I
    With Sheets("BCTH")
        sArr = .Range(.Range("B12"), .Range("B65535").End(3)).Resize(, 15).Value
    End With
    ReDim dArr(1 To UBound(sArr), 1 To 9)
    For I = 1 To UBound(sArr)
        If sArr(I, 12) <= 100 Then
            tem = sArr(I, 1)
            K = K + 1
            dArr(K, 1) = K: dArr(K, 2) = sArr(I, 1): dArr(K, 3) = sArr(I, 2)
            dArr(K, 4) = sArr(I, 5): dArr(K, 5) = sArr(I, 6): dArr(K, 6) = sArr(I, 12)
            dArr(K, 7) = tArr(Dic.Item(tem), 7): dArr(K, 8) = tArr(Dic.Item(tem), 8): dArr(K, 9) = sArr(I, 15)
        End If
    Next I
    With Sheet3
        .Range("A6:I" & .Range("A65535").End(3).Row + 1).ClearContents
        .Range("A6").Resize(K, 9) = dArr
    End With
End Sub
P/s: Dầu âm là do máy tính chạy ra đừng trừ lương lái máy tội họ ( Có thì cho nghỉ việc :D nhẹ nhẹ vậy thôi...)
 
Upvote 0
PacificPR đã viết:
Code lấy dầu Âm, Âm dầu đây
Mã: 
Sub DauAm()
    Dim sArr, dArr, tArr, I As Long, K As Long
    Dim Dic As Object, tem As String
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheets("CSDL")
        tArr = .Range(.Range("C11"), .Range("C65535").End(3)).Resize(, 8).Value
    End With
    For I = 1 To UBound(tArr, 1)
        Dic.Item(tArr(I, 1)) = I
    Next I
    With Sheets("BCTH")
        sArr = .Range(.Range("B12"), .Range("B65535").End(3)).Resize(, 15).Value
    End With
    ReDim dArr(1 To UBound(sArr), 1 To 9)
    For I = 1 To UBound(sArr)
        If sArr(I, 12) <= 100 Then
            tem = sArr(I, 1)
            K = K + 1
            dArr(K, 1) = K: dArr(K, 2) = sArr(I, 1): dArr(K, 3) = sArr(I, 2)
            dArr(K, 4) = sArr(I, 5): dArr(K, 5) = sArr(I, 6): dArr(K, 6) = sArr(I, 12)
            dArr(K, 7) = tArr(Dic.Item(tem), 7): dArr(K, 8) = tArr(Dic.Item(tem), 8): dArr(K, 9) = sArr(I, 15)
        End If
    Next I
    With Sheet3
        .Range("A6:I" & .Range("A65535").End(3).Row + 1).ClearContents
        .Range("A6").Resize(K, 9) = dArr
    End With
End Sub
P/s: Dầu âm là do máy tính chạy ra đừng trừ lương lái máy tội họ ( Có thì cho nghỉ việc :D nhẹ nhẹ vậy thôi...)
Nhấp chuột vào đây để mở rộng...
Ok rồi. Thanks bro nhé. Tính mình hiền lành lắm, diệt cỏ toàn diệt tận gốc thôi =))))
 
Upvote 0
Upvote 0
Lúc đầu e cũng dùng vlookup nhưng file nặng máy chạy chậm nên mới chuyển hết sang code thế này cho nhanh ạ
 
Upvote 0
Bạn ơi. Trog quá trình chạy lại phát sih 1 lỗi, đó là nếu như cột I của sheet "BCHN" nhập hơi nhiều số 0 hoặc là trống nhiều ô dữ liệu thì k chạy được sheet "BCTH" và nó báo lỗi như hình dưới. Vì k phải khi nào mình cũng nhập được hết dữ liệu, mà k nhập hết thì nó lại k chạy đc ra BCTH. Bạn giúp mìh với !upload_2017-8-14_13-54-26.png
 

File đính kèm

  • upload_2017-8-14_13-51-43.png
    upload_2017-8-14_13-51-43.png
    188.9 KB · Đọc: 2
Upvote 0
LightStar252 đã viết:
Bạn ơi. Trog quá trình chạy lại phát sih 1 lỗi, đó là nếu như cột I của sheet "BCHN" nhập hơi nhiều số 0 hoặc là trống nhiều ô dữ liệu thì k chạy được sheet "BCTH" và nó báo lỗi như hình dưới. Vì k phải khi nào mình cũng nhập được hết dữ liệu, mà k nhập hết thì nó lại k chạy đc ra BCTH. Bạn giúp mìh với !View attachment 181523
Nhấp chuột vào đây để mở rộng...
Bạn đính kèm file lỗi lên. Vì lâu quá rồi hiện tại chưa hình dung lại được
 
Upvote 0

File đính kèm

Upvote 0
Với nhờ bạn giúp mình làm cái nút ấn lệnh chạy code Âm dầu với. Thanks bạn nhiều !
 
Upvote 0
LightStar252 đã viết:
Hai trườg hợp trống nhiều ô dữ liệu và có nhiều sô "0" đây, chạy sheet "BCHN" đều bị lỗi Division by zero
Nhấp chuột vào đây để mở rộng...
Cái đó họ nói là biểu thức chia cho số 0. Bạn thử sửa lại như thế này xem
Mã: 
Sub Tonghop()
    Dim sArr(), tArr(), dArr(), I As Long, K As Long, Thang As Long
    Dim Dic As Object, tem As String
Set Dic = CreateObject("Scripting.Dictionary")
Thang = Month(Sheets("BCTH").Range("G6"))
With Sheets("CSDL")
    tArr = .Range(.Range("B11"), .Range("B65535").End(3)).Resize(, 6).Value
End With
For I = 1 To UBound(tArr, 1)
    Dic.Item(tArr(I, 1)) = I
Next I
With Sheets("BCHN")
    sArr = .Range(.Range("B10"), .Range("B65535").End(3)).Resize(, 15).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 16)
For I = 1 To UBound(sArr, 1)
    If Month(sArr(I, 1)) = Thang Then
        tem = sArr(I, 3)
        If Not Dic.Exists(tem) Then
            K = K + 1
            Dic.Add tem, K
            dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 2): dArr(K, 3) = tem
            dArr(K, 4) = tArr(Dic.Item(tem), 5): dArr(K, 5) = tArr(Dic.Item(tem), 6)
            dArr(K, 6) = sArr(I, 8): dArr(K, 7) = sArr(I, 9)
            dArr(K, 10) = sArr(I, 6)
            dArr(K, 16) = sArr(I, 14)
        Else
            dArr(Dic.Item(tem), 6) = dArr(Dic.Item(tem), 6) + sArr(I, 8)
            dArr(Dic.Item(tem), 7) = dArr(Dic.Item(tem), 7) + sArr(I, 9)
            dArr(Dic.Item(tem), 16) = sArr(I, 14)
            dArr(Dic.Item(tem), 11) = sArr(I, 7)
            dArr(K, 8) = dArr(K, 4) * dArr(K, 10): dArr(K, 9) = dArr(K, 4) * dArr(K, 11)
            dArr(K, 12) = dArr(K, 5) * dArr(K, 6)
            dArr(K, 13) = dArr(K, 12) - (dArr(K, 7) + dArr(K, 8) - dArr(K, 9))
            If dArr(K, 6) <> 0 Then dArr(K, 14) = (dArr(K, 8) + dArr(K, 7) - dArr(K, 9)) / dArr(K, 6)
            dArr(K, 15) = dArr(K, 5) - dArr(K, 14)
        End If
    End If
Next I
With Sheets("BCTH")
    .Range("A12:P" & .Range("A65535").End(3).Row + 1).ClearContents
    .Range("A12").Resize(K, 16) = dArr
End With
Set Dic = Nothing
End Sub
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

B
Bỏ lọc và sort trong VBA
Trả lời
1
Đọc
48
Bảo_Anh_
B
K
Điền giá trị ô thay vì địa chỉ ô
Trả lời
5
Đọc
195
DeTong
D
T
Xin hỏi về bảng lương
Trả lời
1
Đọc
115
SA_DQ
SA_DQ
T
Nhờ anh chị xem giúp file bị lỗi gì mà chạy rất chậm/lag - File tính tiền nhà trọ
Trả lời
3
Đọc
103
Thaik05
T
J
chiết khấu ở hóa đơn bán lẻ, lưu vào sheet tổng hợp (1 người xem)
Trả lời
2
Đọc
73
le_vis
L
2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD
    • Thích
Trả lời
8
Đọc
708
Hoàng Tuấn 868
H
B
Sau 1 tháng Mã Lại reset về 1 trở lên (2 người xem)
    • Chấp nhận
Trả lời
23
Đọc
359
SA_DQ
SA_DQ
H
Đánh số thứ thự phiếu thu chi
Trả lời
16
Đọc
325
HangktGTN
H
4
HỌC ĐẠI LÝ THUẾ
Trả lời
1
Đọc
51
Hoàng Tuấn 868
H
B
Chuyển số tiền thành chữ
Trả lời
3
Đọc
86
bongngongo
B
S
Tạo sheet mới từ dữ liệu 2 sheet khác ĐVT
Trả lời
1
Đọc
112
Hoàng Tuấn 868
H
H
  • Question Question
Xin giúp đỡ về tạo hàm excel với C# và excel-dna
Trả lời
0
Đọc
86
hdcv.excel
H
N
  • Question Question
Cho em hỏi về mail merge bằng vba
Trả lời
5
Đọc
175
Hoàng Tuấn 868
H
T
Khóa cột cập nhật dữ liệu
Trả lời
0
Đọc
78
tnkhanhvy
T
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
411
Đọc
50K
ongke0711
ongke0711
H
Tìm kiếm thông tin chi tiết trên sheet tổng hợp
Trả lời
1
Đọc
109
LOGANWover
L
Gà Công Nghệ
Tô màu họ và tên bị trùng từ 2 sheet khác nhau
Trả lời
6
Đọc
171
Gà Công Nghệ
Gà Công Nghệ
A
  • Question Question
Giải thích giúp mình code giải phóng bộ nhớ từ biến
Trả lời
20
Đọc
9K
nguyendang95
N
Nguyenkhang2404
giúp đỡ lọc dữ liệu nâng cao (1 người xem)
Trả lời
22
Đọc
780
Phan Thế Hiệp
Phan Thế Hiệp
B
Dùng button trên forrm để gọi bàn phím ảo win 10(OSK)
Trả lời
5
Đọc
171
huhumalu
H
Xem thêm…

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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom