Cải thiện tốc độ code, (Code đổ dữ liệu từ sheets A qua Sheet B quá chậm) (1 người xem)

guitarnguyen1989 · 18/4/19

Xin chào a/c !

Vấn đề là mình có viết một code dựa theo hàm jonspect của anh ndu96081631 Nhưng tốc độ xử lý quá chậm . Mình nhơ A/C giúp đỡ xử lý vấn đề này , cụ thể như sau :

- File gồm 3 sheet: (Đình kèm file)
1. sheets("Pak_bill") ( Chứa bao bì cấu thành nên 1 sản phẩm ... ví dụ : 1 Sản phẩm A thì cần 1 bao bì A1 ,2 bao bì A2, 3 bao bì A3... )
2. Sheets("pak_output") ( Sheets để đổ dữ liệu sau khi chạy code )
3. Sheets("Prod_plan") ( Sheets kế hoạch sản xuất : bao gồm nhiều loại sản phẩm được sản xuất theo số lệnh sản xuấ t)

Bước 1: Lấy dữ liệu từ sheets("prod_plan") đổ sang sheets("pak_output"). ( đổ theo lệnh sản xuất :LSX1801001)
Bước 2 : Căn cứ vào các mã hàng đã đổ qua sheets("pak_output") , để tìm bao bì cấu thành nên sản phẩm , dữ liệu được lấy từ sheets("Pak_Bill") , tham khảo hàm Jonspect của anh ndu96081631
Bước 3 : Lấy số lượng cấu thành của bao bì đem nhân số lượng sản phẩm sản xuất sẽ ra được số lượng bao bì cần xuất .

Code bước 1

Mã:

lastrow = Sheets("Prod_Plan").Cells(Rows.Count, "B").End(xlUp).Row
With Sheets("Prod_Plan").Range("D9:D" & lastrow)
Set LastCell = .Cells(.Cells.Count)
Set Rng = .Find(Sheets("Prod_Plan").Range("F2"), After:=LastCell, LookIn:=xlValues, LookAt:=xlWhole)
FirstAddress = Rng.Address
If Not Rng Is Nothing Then
Do
R = Sheets("Pak_output").Cells(Rows.Count, "D").End(xlUp).Row + 1
SaveRow = Rng.Row
Select Case Rng.Column
    Case 4
    With Sheets("Pak_output")
        .Cells(R, 1) = Rng.Offset(, 1) ' ma san pham
        .Cells(R, 2) = Rng.Offset(, 2) ' ten san pham
        .Cells(R, 3) = Rng.Offset(, 4) ' so luong
    End With

Code bước 2

Mã:

If Not Sheets("Pak_output").Cells(R, 1) Is Nothing Then
With Sheets("Pak-Bill")
Tmp1 = Func.Transpose(FindSpec(Sheets("Pak_output").Cells(R, 1).Value, .Range("Pak_Bill"), 3))
Tmp2 = Func.Transpose(FindSpec(Sheets("Pak_output").Cells(R, 1).Value, .Range("Pak_Bill"), 4))
Tmp3 = Func.Transpose(FindSpec(Sheets("Pak_output").Cells(R, 1).Value, .Range("Pak_Bill"), 5))
Tmp4 = Func.Transpose(FindSpec(Sheets("Pak_output").Cells(R, 1).Value, .Range("Pak_Bill"), 6))
End With
Sheets("Pak_output").Cells(R, 1).Offset(, 3).Resize(UBound(Tmp1)).Value = Tmp1
Sheets("Pak_output").Cells(R, 1).Offset(, 4).Resize(UBound(Tmp1)).Value = Tmp2
Sheets("Pak_output").Cells(R, 1).Offset(, 5).Resize(UBound(Tmp1)).Value = Tmp3
Sheets("Pak_output").Cells(R, 1).Offset(, 6).Resize(UBound(Tmp1)).Value = Tmp4
End If

Code bước 3

Mã:

With Sheets("Pak_output")
RR = Sheets("Pak_output").Cells(Rows.Count, "F").End(xlUp).Row
For i = R + 1 To RR
Cells(i, 8) = Val(.Cells(i, 6).Value) * Val(.Cells(R, 3).Value)
Next i

Hàm jonspect

Mã:

Option Explicit
Function FindSpec(ID As String, SrcRng As Range, Col_Index As Long)
  Dim Clls As Range, Temp
  With CreateObject("Scripting.Dictionary")
    For Each Clls In SrcRng.Resize(, 1)
      If Clls <> "" Then Temp = Clls.Value
      If Clls <> "" And Not .Exists(Clls.Value) Then
        .Add Clls.Value, Clls(, Col_Index).Value
      ElseIf Clls(, Col_Index) <> "" Then
        .Item(Temp) = .Item(Temp) & vbBack & Clls(, Col_Index).Value
      End If
    Next
    FindSpec = Split(.Item(ID), vbBack)
  End With
End Function

snow25 · 18/4/19

guitarnguyen1989 đã viết:
Xin chào a/c !

Vấn đề là mình có viết một code dựa theo hàm jonspect của anh ndu96081631 Nhưng tốc độ xử lý quá chậm . Mình nhơ A/C giúp đỡ xử lý vấn đề này , cụ thể như sau :

- File gồm 3 sheet: (Đình kèm file)
1. sheets("Pak_bill") ( Chứa bao bì cấu thành nên 1 sản phẩm ... ví dụ : 1 Sản phẩm A thì cần 1 bao bì A1 ,2 bao bì A2, 3 bao bì A3... )
2. Sheets("pak_output") ( Sheets để đổ dữ liệu sau khi chạy code )
3. Sheets("Prod_plan") ( Sheets kế hoạch sản xuất : bao gồm nhiều loại sản phẩm được sản xuất theo số lệnh sản xuấ t)

Bước 1: Lấy dữ liệu từ sheets("prod_plan") đổ sang sheets("pak_output"). ( đổ theo lệnh sản xuất :LSX1801001)
Bước 2 : Căn cứ vào các mã hàng đã đổ qua sheets("pak_output") , để tìm bao bì cấu thành nên sản phẩm , dữ liệu được lấy từ sheets("Pak_Bill") , tham khảo hàm Jonspect của anh ndu96081631
Bước 3 : Lấy số lượng cấu thành của bao bì đem nhân số lượng sản phẩm sản xuất sẽ ra được số lượng bao bì cần xuất .

Code bước 1

Mã:

lastrow = Sheets("Prod_Plan").Cells(Rows.Count, "B").End(xlUp).Row With Sheets("Prod_Plan").Range("D9:D" & lastrow) Set LastCell = .Cells(.Cells.Count) Set Rng = .Find(Sheets("Prod_Plan").Range("F2"), After:=LastCell, LookIn:=xlValues, LookAt:=xlWhole) FirstAddress = Rng.Address If Not Rng Is Nothing Then Do R = Sheets("Pak_output").Cells(Rows.Count, "D").End(xlUp).Row + 1 SaveRow = Rng.Row Select Case Rng.Column Case 4 With Sheets("Pak_output") .Cells(R, 1) = Rng.Offset(, 1) ' ma san pham .Cells(R, 2) = Rng.Offset(, 2) ' ten san pham .Cells(R, 3) = Rng.Offset(, 4) ' so luong End With

Code bước 2

Mã:

If Not Sheets("Pak_output").Cells(R, 1) Is Nothing Then With Sheets("Pak-Bill") Tmp1 = Func.Transpose(FindSpec(Sheets("Pak_output").Cells(R, 1).Value, .Range("Pak_Bill"), 3)) Tmp2 = Func.Transpose(FindSpec(Sheets("Pak_output").Cells(R, 1).Value, .Range("Pak_Bill"), 4)) Tmp3 = Func.Transpose(FindSpec(Sheets("Pak_output").Cells(R, 1).Value, .Range("Pak_Bill"), 5)) Tmp4 = Func.Transpose(FindSpec(Sheets("Pak_output").Cells(R, 1).Value, .Range("Pak_Bill"), 6)) End With Sheets("Pak_output").Cells(R, 1).Offset(, 3).Resize(UBound(Tmp1)).Value = Tmp1 Sheets("Pak_output").Cells(R, 1).Offset(, 4).Resize(UBound(Tmp1)).Value = Tmp2 Sheets("Pak_output").Cells(R, 1).Offset(, 5).Resize(UBound(Tmp1)).Value = Tmp3 Sheets("Pak_output").Cells(R, 1).Offset(, 6).Resize(UBound(Tmp1)).Value = Tmp4 End If

Code bước 3

Mã:

With Sheets("Pak_output") RR = Sheets("Pak_output").Cells(Rows.Count, "F").End(xlUp).Row For i = R + 1 To RR Cells(i, 8) = Val(.Cells(i, 6).Value) * Val(.Cells(R, 3).Value) Next i

Hàm jonspect

Mã:

Option Explicit Function FindSpec(ID As String, SrcRng As Range, Col_Index As Long) Dim Clls As Range, Temp With CreateObject("Scripting.Dictionary") For Each Clls In SrcRng.Resize(, 1) If Clls <> "" Then Temp = Clls.Value If Clls <> "" And Not .Exists(Clls.Value) Then .Add Clls.Value, Clls(, Col_Index).Value ElseIf Clls(, Col_Index) <> "" Then .Item(Temp) = .Item(Temp) & vbBack & Clls(, Col_Index).Value End If Next FindSpec = Split(.Item(ID), vbBack) End With End Function

Bạn chạy code này xem đúng không nhé.

Mã:

Sub chuyendulieu()
    Dim arr, arr1, arr2, dic As Object, a As Long, lr As Long, i As Long, j As Long, dk As String, T, k As Integer, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Pak-Bill")
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         arr = .Range("A9:F" & lr).Value
         For i = 1 To UBound(arr, 1)
             If arr(i, 1) = Empty Then arr(i, 1) = arr(i - 1, 1)
             If Not dic.exists(arr(i, 1)) Then
                dic.Add arr(i, 1), "#" & i
             Else
                dic.Item(arr(i, 1)) = dic.Item(arr(i, 1)) & "#" & i
             End If
         Next i
   End With
   With Sheets("Prod_Plan")
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        If lr < 9 Then Exit Sub
        arr1 = .Range("D9:H" & lr).Value
        ReDim arr2(1 To UBound(arr1, 1) * 20, 1 To 8)
        dk = .Range("F2").Value
        For i = 1 To UBound(arr1, 1)
            If dk = arr1(i, 1) Then
               If dic.exists(arr1(i, 2)) Then
                  T = Split(dic.Item(arr1(i, 2)), "#")
                  a = a + 1
                  arr2(a, 1) = arr1(i, 2)
                  arr2(a, 2) = arr1(i, 3)
                  arr2(a, 3) = arr1(i, 5)
                  For k = 2 To UBound(T)
                      a = a + 1
                      b = T(k)
                      arr2(a, 4) = arr(b, 3)
                      arr2(a, 5) = arr(b, 4)
                      arr2(a, 6) = arr(b, 5)
                      arr2(a, 7) = arr(b, 6)
                      arr2(a, 8) = arr1(i, 5) * arr(b, 5)
                  Next k
              End If
           End If
       Next i
  End With
  Set dic = Nothing
  With Sheets("Pak_Output")
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        If lr > 1 Then .Range("A2:H" & lr).ClearContents
        If a Then .Range("A2").Resize(a, 8).Value = arr2
  End With
End Sub

guitarnguyen1989 · 18/4/19

snow25 đã viết:

Bạn chạy code này xem đúng không nhé.

Mã:

Sub chuyendulieu()
    Dim arr, arr1, arr2, dic As Object, a As Long, lr As Long, i As Long, j As Long, dk As String, T, k As Integer, b As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Pak-Bill")
         lr = .Range("C" & Rows.Count).End(xlUp).Row
         arr = .Range("A9:F" & lr).Value
         For i = 1 To UBound(arr, 1)
             If arr(i, 1) = Empty Then arr(i, 1) = arr(i - 1, 1)
             If Not dic.exists(arr(i, 1)) Then
                dic.Add arr(i, 1), "#" & i
             Else
                dic.Item(arr(i, 1)) = dic.Item(arr(i, 1)) & "#" & i
             End If
         Next i
   End With
   With Sheets("Prod_Plan")
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        If lr < 9 Then Exit Sub
        arr1 = .Range("D9:H" & lr).Value
        ReDim arr2(1 To UBound(arr1, 1) * 20, 1 To 8)
        dk = .Range("F2").Value
        For i = 1 To UBound(arr1, 1)
            If dk = arr1(i, 1) Then
               If dic.exists(arr1(i, 2)) Then
                  T = Split(dic.Item(arr1(i, 2)), "#")
                  a = a + 1
                  arr2(a, 1) = arr1(i, 2)
                  arr2(a, 2) = arr1(i, 3)
                  arr2(a, 3) = arr1(i, 5)
                  For k = 2 To UBound(T)
                      a = a + 1
                      b = T(k)
                      arr2(a, 4) = arr(b, 3)
                      arr2(a, 5) = arr(b, 4)
                      arr2(a, 6) = arr(b, 5)
                      arr2(a, 7) = arr(b, 6)
                      arr2(a, 8) = arr1(i, 5) * arr(b, 5)
                  Next k
              End If
           End If
       Next i
  End With
  Set dic = Nothing
  With Sheets("Pak_Output")
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        If lr > 1 Then .Range("A2:H" & lr).ClearContents
        If a Then .Range("A2").Resize(a, 8).Value = arr2
  End With
End Sub

Trên cả tuyệt vời !!!!!!!!11

Cải thiện tốc độ code, (Code đổ dữ liệu từ sheets A qua Sheet B quá chậm) (1 người xem)

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

guitarnguyen1989

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

File đính kèm

snow25

Thành viên gạo cội

File đính kèm

guitarnguyen1989

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

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

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.