Giúp đỡ code trong excel

[Nambienhoa]

Nhờ ACE giúp viết code VBA trong excel theo file đính kèm

 

[snow25]

Nhờ ACE giúp viết code VBA trong excel theo file đính kèm

Tưởng là công việc hóa ra ví dụ về học VBA.Bạn tự nghiên cứu nhé.Áp dụng mảng Array và Dictionary vào cho nó nhanh.

 

[Nambienhoa]

Tưởng là công việc hóa ra ví dụ về học VBA.Bạn tự nghiên cứu nhé.Áp dụng mảng Array và Dictionary vào cho nó nhanh.

Ứng dụng vào công việc em đang làm. Em mù tịt về VBA, mong các AC giúp ah

 

[VetMini]

Tiêu đề chung chung như trên là phạm quy.
Bạn có thể mù tịt về VBA nhưng không thể lấy cớ mù tịt về quy luật viết bài trên diễn đàn.

 

[anhtuan2939]

Em mù tịt về VBA, mong các AC giúp ah

Nếu bạn mù tịt về VBA thì có thể bắt đầu từ Record Macro.

 

[snow25]

Ứng dụng vào công việc em đang làm. Em mù tịt về VBA, mong các AC giúp ah

Thử code .

Sub abc()
    Dim i As Long, lr As Long, arr, kq, dic As Object, a As Long, b As Long, dk As Long, c As Long, k As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Bang he so tang them")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A4:B" & lr).Value
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            dic.Item(dk) = arr(i, 2)
        Next i
   End With
   With Sheets("Bang qua trinh")
        arr = .Range("A3:C7").Value
        ReDim kq(1 To UBound(arr) + 100, 1 To 6)
        For i = 1 To UBound(arr)
            a = Right(arr(i, 1), 4)
            b = Right(arr(i, 2), 4)
            If a - b = 0 Then
               c = c + 1
               kq(c, 1) = arr(i, 1)
               kq(c, 2) = arr(i, 2)
               kq(c, 3) = CLng(Left(arr(i, 2), 2)) - CLng(Left(arr(i, 1), 2)) + 1
               kq(c, 4) = arr(i, 3)
               If a < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(a)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
            ElseIf b - a = 1 Then
               c = c + 1
               kq(c, 1) = arr(i, 1)
               kq(c, 2) = "12/" & a
               kq(c, 3) = 12 - CLng(Left(arr(i, 1), 2)) + 1
               kq(c, 4) = arr(i, 3)
               If a < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(a)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
               c = c + 1
               kq(c, 1) = "01/" & b
               kq(c, 2) = arr(i, 2)
               kq(c, 3) = CLng(Left(arr(i, 2), 2))
               kq(c, 4) = arr(i, 3)
               If b < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(b)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
           ElseIf b - a > 1 Then
               c = c + 1
               kq(c, 1) = arr(i, 1)
               kq(c, 2) = "12/" & a
               kq(c, 3) = 12 - CLng(Left(arr(i, 1), 2)) + 1
               kq(c, 4) = arr(i, 3)
               If a < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(a)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
           For k = a + 1 To b - 1
               c = c + 1
               kq(c, 1) = "01/" & k
               kq(c, 2) = "12/" & k
               kq(c, 3) = 12
               kq(c, 4) = arr(i, 3)
               If k < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(k)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
            Next k
               c = c + 1
               kq(c, 1) = "01/" & c
               kq(c, 2) = arr(i, 2)
               kq(c, 3) = CLng(Left(arr(i, 2), 2))
               kq(c, 4) = arr(i, 3)
               If b < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(b)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
            End If
        Next i
    End With
    With Sheets("bang qua trinh chi tiet")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:F" & lr).ClearContents
         .Range("A3:F3").Resize(c).Value = kq
    End With
    Set dic = Nothing
End Sub

 

[Nambienhoa]

Thử code .

Sub abc()
    Dim i As Long, lr As Long, arr, kq, dic As Object, a As Long, b As Long, dk As Long, c As Long, k As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Bang he so tang them")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A4:B" & lr).Value
        For i = 1 To UBound(arr)
            dk = arr(i, 1)
            dic.Item(dk) = arr(i, 2)
        Next i
   End With
   With Sheets("Bang qua trinh")
        arr = .Range("A3:C7").Value
        ReDim kq(1 To UBound(arr) + 100, 1 To 6)
        For i = 1 To UBound(arr)
            a = Right(arr(i, 1), 4)
            b = Right(arr(i, 2), 4)
            If a - b = 0 Then
               c = c + 1
               kq(c, 1) = arr(i, 1)
               kq(c, 2) = arr(i, 2)
               kq(c, 3) = CLng(Left(arr(i, 2), 2)) - CLng(Left(arr(i, 1), 2)) + 1
               kq(c, 4) = arr(i, 3)
               If a < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(a)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
            ElseIf b - a = 1 Then
               c = c + 1
               kq(c, 1) = arr(i, 1)
               kq(c, 2) = "12/" & a
               kq(c, 3) = 12 - CLng(Left(arr(i, 1), 2)) + 1
               kq(c, 4) = arr(i, 3)
               If a < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(a)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
               c = c + 1
               kq(c, 1) = "01/" & b
               kq(c, 2) = arr(i, 2)
               kq(c, 3) = CLng(Left(arr(i, 2), 2))
               kq(c, 4) = arr(i, 3)
               If b < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(b)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
           ElseIf b - a > 1 Then
               c = c + 1
               kq(c, 1) = arr(i, 1)
               kq(c, 2) = "12/" & a
               kq(c, 3) = 12 - CLng(Left(arr(i, 1), 2)) + 1
               kq(c, 4) = arr(i, 3)
               If a < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(a)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
           For k = a + 1 To b - 1
               c = c + 1
               kq(c, 1) = "01/" & k
               kq(c, 2) = "12/" & k
               kq(c, 3) = 12
               kq(c, 4) = arr(i, 3)
               If k < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(k)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
            Next k
               c = c + 1
               kq(c, 1) = "01/" & c
               kq(c, 2) = arr(i, 2)
               kq(c, 3) = CLng(Left(arr(i, 2), 2))
               kq(c, 4) = arr(i, 3)
               If b < 1995 Then
                  kq(c, 5) = 10.2
               Else
                  kq(c, 5) = dic.Item(b)
               End If
               kq(c, 6) = kq(c, 5) * kq(c, 4)
            End If
        Next i
    End With
    With Sheets("bang qua trinh chi tiet")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:F" & lr).ClearContents
         .Range("A3:F3").Resize(c).Value = kq
    End With
    Set dic = Nothing
End Sub

Mã code đã ok rồi, cám ơn anh nhiều ha

Bài đã được tự động gộp: 2/11/22

Tiêu đề chung chung như trên là phạm quy.
Bạn có thể mù tịt về VBA nhưng không thể lấy cớ mù tịt về quy luật viết bài trên diễn đàn.

Cám ơn bạn đã nhắc nhở, mình sẽ cố gắng tìm hiểu cách đăng bài