Giúp mình viết Code VBA để điều chuyển hàng hóa

Liên hệ QC
Q

Quỳnh Như 7648

Thành viên mới
Tham gia
21/9/17
Bài viết
20
Được thích
0
Giới tính
Nữ
Tại sheet THUA_THIEU, mình muốn dò tìm giá trị của cột thừa, nếu >0 thì trừ cho giá trị >0 ở cột thiếu và ghi nhận lại vào bảng của sheet DIEU_CHUYEN, lặp lại cho đến hết dữ liệu và chuyển sang mã khác. Ưu tiên điều chuyển trong cùng Khu Vực và cùng 1 cụm trước, sau đó mới điều chuyển khác cụm, khác KV.

Không biết có thể dùng code VBA để điều chuyển hàng được không cả nhà xem giúp mình với. Vì dữ liệu rất nhiều không thể làm tay nổi
1f641.png

Xin cảm ơn
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Quỳnh Như 7648 đã viết:
Tại sheet THUA_THIEU, mình muốn dò tìm giá trị của cột thừa, nếu >0 thì trừ cho giá trị >0 ở cột thiếu và ghi nhận lại vào bảng của sheet DIEU_CHUYEN, lặp lại cho đến hết dữ liệu và chuyển sang mã khác. Ưu tiên điều chuyển trong cùng Khu Vực và cùng 1 cụm trước, sau đó mới điều chuyển khác cụm, khác KV.

Không biết có thể dùng code VBA để điều chuyển hàng được không cả nhà xem giúp mình với. Vì dữ liệu rất nhiều không thể làm tay nổi
1f641.png

Xin cảm ơn
Nhấp chuột vào đây để mở rộng...
Chạy code
Mã: 
Sub xyz()
  Dim sArr(), sCH(), Res() As String, Res2()
  Dim sRow&, sCol&, i&, r&, fRow&, j&, jk&, mSP$
  Const rMax As String = 10000 'So dong ket qua toi da 10.000 dong
  With Sheets("THUA_THIEU")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    sCol = .Cells(1, 16000).End(xlToLeft).Column
    .Range("A4", .Cells(i, sCol)).Sort .[C4], 1, .[B4], , 1, Header:=xlNo
    sCH = .Range("A4:A" & i).Value
    sArr = .Range("D4", .Cells(i, sCol)).Value
  End With

  sRow = UBound(sArr)
  ReDim Res(1 To rMax, 1 To 3)
  ReDim Res2(1 To rMax, 1 To 1)
  For jk = 4 To sCol Step 2
    mSP = Sheets("THUA_THIEU").Cells(1, jk).Value
    j = jk - 3
    fRow = 1
    For i = 1 To sRow
      If sArr(i, j) > 0 Then
        For r = fRow To sRow
          If sArr(r, j + 1) > 0 Then
            k = k + 1
            Res(k, 1) = mSP: Res(k, 2) = sCH(i, 1): Res(k, 3) = sCH(r, 1)
            If sArr(i, j) > sArr(r, j + 1) Then
              Res2(k, 1) = sArr(r, j + 1)
              sArr(i, j) = sArr(i, j) - sArr(r, j + 1)
              sArr(r, j + 1) = 0
            Else
              Res2(k, 1) = sArr(i, j)
              sArr(r, j + 1) = sArr(r, j + 1) - sArr(i, j)
              sArr(i, j) = 0
              fRow = r:     Exit For
            End If
          End If
        Next r
      End If
    Next i
  Next jk
  Sheets("THUA_THIEU").Range("D4").Resize(sRow, sCol - 3) = sArr
  With Sheets("DIEU_CHUYEN")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:D" & i).ClearContents
    If k Then
      .Range("A2:C2").Resize(k) = Res
      .Range("D2").Resize(k) = Res2
      MsgBox ("Done!")
    Else
      MsgBox ("Khong co San Pham dieu chuyen!")
    End If
  End With
End Sub
 

File đính kèm

Upvote 0
HieuCD đã viết:
Chạy code
Mã: 
Sub xyz()
  Dim sArr(), sCH(), Res() As String, Res2()
  Dim sRow&, sCol&, i&, r&, fRow&, j&, jk&, mSP$
  Const rMax As String = 10000 'So dong ket qua toi da 10.000 dong
  With Sheets("THUA_THIEU")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    sCol = .Cells(1, 16000).End(xlToLeft).Column
    .Range("A4", .Cells(i, sCol)).Sort .[C4], 1, .[B4], , 1, Header:=xlNo
    sCH = .Range("A4:A" & i).Value
    sArr = .Range("D4", .Cells(i, sCol)).Value
  End With

  sRow = UBound(sArr)
  ReDim Res(1 To rMax, 1 To 3)
  ReDim Res2(1 To rMax, 1 To 1)
  For jk = 4 To sCol Step 2
    mSP = Sheets("THUA_THIEU").Cells(1, jk).Value
    j = jk - 3
    fRow = 1
    For i = 1 To sRow
      If sArr(i, j) > 0 Then
        For r = fRow To sRow
          If sArr(r, j + 1) > 0 Then
            k = k + 1
            Res(k, 1) = mSP: Res(k, 2) = sCH(i, 1): Res(k, 3) = sCH(r, 1)
            If sArr(i, j) > sArr(r, j + 1) Then
              Res2(k, 1) = sArr(r, j + 1)
              sArr(i, j) = sArr(i, j) - sArr(r, j + 1)
              sArr(r, j + 1) = 0
            Else
              Res2(k, 1) = sArr(i, j)
              sArr(r, j + 1) = sArr(r, j + 1) - sArr(i, j)
              sArr(i, j) = 0
              fRow = r:     Exit For
            End If
          End If
        Next r
      End If
    Next i
  Next jk
  Sheets("THUA_THIEU").Range("D4").Resize(sRow, sCol - 3) = sArr
  With Sheets("DIEU_CHUYEN")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:D" & i).ClearContents
    If k Then
      .Range("A2:C2").Resize(k) = Res
      .Range("D2").Resize(k) = Res2
      MsgBox ("Done!")
    Else
      MsgBox ("Khong co San Pham dieu chuyen!")
    End If
  End With
End Sub
Nhấp chuột vào đây để mở rộng...

Cám ơn bạn rất nhiều
Bài đã được tự động gộp:

HieuCD đã viết:
Chạy code
Mã: 
Sub xyz()
  Dim sArr(), sCH(), Res() As String, Res2()
  Dim sRow&, sCol&, i&, r&, fRow&, j&, jk&, mSP$
  Const rMax As String = 10000 'So dong ket qua toi da 10.000 dong
  With Sheets("THUA_THIEU")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    sCol = .Cells(1, 16000).End(xlToLeft).Column
    .Range("A4", .Cells(i, sCol)).Sort .[C4], 1, .[B4], , 1, Header:=xlNo
    sCH = .Range("A4:A" & i).Value
    sArr = .Range("D4", .Cells(i, sCol)).Value
  End With

  sRow = UBound(sArr)
  ReDim Res(1 To rMax, 1 To 3)
  ReDim Res2(1 To rMax, 1 To 1)
  For jk = 4 To sCol Step 2
    mSP = Sheets("THUA_THIEU").Cells(1, jk).Value
    j = jk - 3
    fRow = 1
    For i = 1 To sRow
      If sArr(i, j) > 0 Then
        For r = fRow To sRow
          If sArr(r, j + 1) > 0 Then
            k = k + 1
            Res(k, 1) = mSP: Res(k, 2) = sCH(i, 1): Res(k, 3) = sCH(r, 1)
            If sArr(i, j) > sArr(r, j + 1) Then
              Res2(k, 1) = sArr(r, j + 1)
              sArr(i, j) = sArr(i, j) - sArr(r, j + 1)
              sArr(r, j + 1) = 0
            Else
              Res2(k, 1) = sArr(i, j)
              sArr(r, j + 1) = sArr(r, j + 1) - sArr(i, j)
              sArr(i, j) = 0
              fRow = r:     Exit For
            End If
          End If
        Next r
      End If
    Next i
  Next jk
  Sheets("THUA_THIEU").Range("D4").Resize(sRow, sCol - 3) = sArr
  With Sheets("DIEU_CHUYEN")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:D" & i).ClearContents
    If k Then
      .Range("A2:C2").Resize(k) = Res
      .Range("D2").Resize(k) = Res2
      MsgBox ("Done!")
    Else
      MsgBox ("Khong co San Pham dieu chuyen!")
    End If
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn ơi. Mình có thể xét thêm điều kiện nếu giá trị bằng nhau giữa cột thừa và cột thiếu thì ưu tiên điều chuyển trước không? Để đỡ phải tách nhỏ.
 
Lần chỉnh sửa cuối:
Upvote 0
Quỳnh Như 7648 đã viết:
Cám ơn bạn rất nhiều
Bài đã được tự động gộp:


Bạn ơi. Mình có thể xét thêm điều kiện nếu giá trị bằng nhau giữa cột thừa và cột thiếu thì ưu tiên điều chuyển trước không? Để đỡ phải tách nhỏ.
Nhấp chuột vào đây để mở rộng...
Còn gì không, chỉ chỉnh thêm 1 lần
 
Upvote 0
Quỳnh Như 7648 đã viết:
Mình muốn ưu tiên điều chuyển giá trị lớn đến bé, và giá trị thừa thiếu bằng nhau thì ưu tiên điều chuyển để đỡ phải tách nhỏ.
Cám ơn bạn
Nhấp chuột vào đây để mở rộng...
Xác định thứ tự ưu tiên điều chuyển ?
_ Trong cùng Khu Vực và cùng 1 cụm trước, sau đó mới điều chuyển khác cụm, khác KV.
_ Giá trị thừa thiếu bằng nhau
_ Giá trị lớn đến bé
 
Upvote 0
HieuCD đã viết:
Xác định thứ tự ưu tiên điều chuyển ?
_ Trong cùng Khu Vực và cùng 1 cụm trước, sau đó mới điều chuyển khác cụm, khác KV.
_ Giá trị thừa thiếu bằng nhau
_ Giá trị lớn đến bé
Nhấp chuột vào đây để mở rộng...

Mình mong muốn thứ tự ưu tiên như sau:
_ Trong cùng Khu Vực và cùng 1 cụm trước, sau đó mới điều chuyển khác cụm, khác KV.
_ Giá trị lớn đến bé
_ Giá trị thừa thiếu bằng nhau

Mong bạn chỉnh giúp. Mình cám ơn
 
Upvote 0
Quỳnh Như 7648 đã viết:
Mình mong muốn thứ tự ưu tiên như sau:
_ Trong cùng Khu Vực và cùng 1 cụm trước, sau đó mới điều chuyển khác cụm, khác KV.
_ Giá trị lớn đến bé
_ Giá trị thừa thiếu bằng nhau

Mong bạn chỉnh giúp. Mình cám ơn
Nhấp chuột vào đây để mở rộng...
Theo thứ tự
_ Giá trị lớn đến bé
_ Giá trị thừa thiếu bằng nhau
Không làm được
Chỉ làm được
_ Giá trị thừa thiếu bằng nhau
_ Giá trị lớn đến bé
 
Upvote 0
Quỳnh Như 7648 đã viết:
Hi, vậy bạn làm giúp mình nhé
Nhấp chuột vào đây để mở rộng...
Kiểm tra lại
Mã: 
Dim aCH(), aTT(), sArr(), aRow(), Res() As String, Res2()
Dim mSP$, Tong#
Dim sRow&, N&, N2&, k&, i&, r&, q&, j&

Sub Main()
  Dim Dic As Object
  Dim fRow&, eRow&, fRow2&, sCol&, ik&
  Const rMax As String = 10000 'So dong ket qua toi da 10.000 dong
 
  ReDim Res(1 To rMax, 1 To 3)
  ReDim Res2(1 To rMax, 1 To 1)
  Set Dic = CreateObject("scripting.dictionary")
  ReDim aRow(1 To 1000, 1 To 4)
  N = 0: N2 = 0: k = 0
 
  Application.ScreenUpdating = False
  With Sheets("THUA_THIEU")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    sCol = .Cells(1, 16000).End(xlToLeft).Column
    .Range("A4", .Cells(eRow, sCol)).Sort .[B4], 1, .[c4], , 1, Header:=xlNo
    aCH = .Range("A4:C" & eRow).Value
    For i = 4 To eRow
      Dic.Add .Range("A" & i).Text, i - 3
      If .Range("B" & i) <> .Range("B" & i - 1) Then
        fRow = i - 3: N = N + 1
        fRow2 = i - 3: N2 = N2 + 1
      ElseIf .Range("C" & i) <> .Range("C" & i - 1) Then
        fRow2 = i - 3: N2 = N2 + 1
      End If
      If .Range("B" & i) <> .Range("B" & i + 1) Then
        aRow(N, 1) = fRow: aRow(N, 2) = i - 3
        Dic.Add .Range("B" & i), N
        aRow(N2, 3) = fRow2: aRow(N2, 4) = i - 3
        Dic.Add .Range("B" & i) & .Range("C" & i), N2
      ElseIf .Range("C" & i) <> .Range("C" & i + 1) Then
        aRow(N2, 3) = fRow2: aRow(N2, 4) = i - 3
        Dic.Add .Range("B" & i) & .Range("C" & i), N2
      End If
    Next i
 
    sRow = UBound(aCH)
    For j = 4 To sCol Step 2
      mSP = .Cells(1, j).Value
      aTT = .Cells(4, j).Resize(sRow, 2).Value
      Tong = 0
      Call KhuVuc_Cum
      If Tong > 0 Then Call KhuVuc
      If Tong > 0 Then Call TatCa
      ReDim aTT(1 To sRow, 1 To 2)
      For i = 1 To sRow
        ik = Dic.Item(sArr(i, 1))
        aTT(ik, 1) = sArr(i, 4)
        aTT(ik, 2) = sArr(i, 5)
      Next i
      .Cells(4, j).Resize(sRow, 2) = aTT 'Gan ket qua
    Next j
  End With
  With Sheets("DIEU_CHUYEN") 'Gan ket qua
    .Range("F2").Resize(sRow, 5).Clear
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:D" & eRow).ClearContents
    If k Then
      .Range("A2:C2").Resize(k) = Res
      .Range("D2").Resize(k) = Res2
      MsgBox ("Done!")
    Else
      MsgBox ("Khong co San Pham dieu chuyen!")
    End If
  End With
  Application.ScreenUpdating = True
End Sub

Private Sub KhuVuc_Cum()
  Dim fRow&, eRow&
  With Sheets("DIEU_CHUYEN")
    .Range("F2").Resize(sRow).NumberFormat = "@"
    .Range("F2").Resize(sRow, 3) = aCH
    .Range("I2").Resize(sRow, 2) = aTT
    .Range("F2:J2").Resize(sRow).Sort .[I2], 2, .[J2], , 2, Header:=xlNo
    .Range("F2:J2").Resize(sRow).Sort .[G2], 1, .[H2], , 1, Header:=xlNo
    sArr = .Range("F2").Resize(sRow, 5).Value
  End With
  For q = 1 To N2
    fRow = aRow(q, 3): eRow = aRow(q, 4)
    Call Trung(fRow, eRow, True)
    Call KhongTrung(fRow, eRow)
  Next q
End Sub

Private Sub KhuVuc()
  Dim fRow&, eRow&
  With Sheets("DIEU_CHUYEN")
    .Range("F2").Resize(sRow, 5) = sArr
    .Range("F2:J2").Resize(sRow).Sort .[G2], 1, .[I2], , 2, .[J2], 2, Header:=xlNo
    sArr = .Range("F2").Resize(sRow, 5).Value
  End With
  For q = 1 To N
    fRow = aRow(q, 1): eRow = aRow(q, 2)
    Call Trung(fRow, eRow, False)
    Call KhongTrung(fRow, eRow)
  Next q
End Sub

Private Sub TatCa()
  Dim fRow&, eRow&
  With Sheets("DIEU_CHUYEN")
    .Range("F2").Resize(sRow, 5) = sArr
    .Range("F2:J2").Resize(sRow).Sort .[I2], 2, .[J2], , 2, Header:=xlNo
    sArr = .Range("F2").Resize(sRow, 5).Value
  End With
  For q = 1 To N
    fRow = 1: eRow = sRow
    Call Trung(fRow, eRow, False)
    Call KhongTrung(fRow, eRow)
  Next q
End Sub

Private Sub Trung(ByRef fRow, ByRef eRow, ByVal bTong As Boolean)
  Dim fRow2&
  fRow2 = fRow
  For i = fRow To eRow
    If bTong Then Tong = Tong + sArr(i, 5)
    If sArr(i, 4) > 0 Then
      For r = fRow2 To eRow
        If sArr(r, 5) > 0 Then
          If sArr(i, 4) = sArr(r, 5) Then
            k = k + 1
            Res(k, 1) = mSP:          Res(k, 2) = sArr(i, 1)
            Res(k, 3) = sArr(r, 1):   Res2(k, 1) = sArr(i, 4)
            sArr(i, 4) = 0:           sArr(r, 5) = 0
            If bTong Then Tong = Tong - sArr(r, 5)
            fRow2 = r + 1
            Exit For
          End If
        End If
      Next r
    End If
  Next i
End Sub

Private Sub KhongTrung(ByRef fRow, ByRef eRow)
  Dim fRow2&
  fRow2 = fRow
  For i = fRow To eRow
    If sArr(i, 4) > 0 Then
      For r = fRow2 To eRow
          If sArr(r, 5) > 0 Then
            k = k + 1
            Res(k, 1) = mSP: Res(k, 2) = sArr(i, 1): Res(k, 3) = sArr(r, 1)
            If sArr(i, 4) > sArr(r, 5) Then
              Res2(k, 1) = sArr(r, 5)
              sArr(i, 4) = sArr(i, 4) - sArr(r, 5)
              Tong = Tong - sArr(r, 5)
              sArr(r, 5) = 0
            Else
              Res2(k, 1) = sArr(i, 4)
              sArr(r, 5) = sArr(r, 5) - sArr(i, 4)
              Tong = Tong - sArr(i, 4)
              sArr(i, 4) = 0
              fRow2 = r:     Exit For
            End If
          End If
      Next r
    End If
  Next i
End Sub
 
Upvote 0
HieuCD đã viết:
Kiểm tra lại
Mã: 
Dim aCH(), aTT(), sArr(), aRow(), Res() As String, Res2()
Dim mSP$, Tong#
Dim sRow&, N&, N2&, k&, i&, r&, q&, j&

Sub Main()
  Dim Dic As Object
  Dim fRow&, eRow&, fRow2&, sCol&, ik&
  Const rMax As String = 10000 'So dong ket qua toi da 10.000 dong

  ReDim Res(1 To rMax, 1 To 3)
  ReDim Res2(1 To rMax, 1 To 1)
  Set Dic = CreateObject("scripting.dictionary")
  ReDim aRow(1 To 1000, 1 To 4)
  N = 0: N2 = 0: k = 0

  Application.ScreenUpdating = False
  With Sheets("THUA_THIEU")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    sCol = .Cells(1, 16000).End(xlToLeft).Column
    .Range("A4", .Cells(eRow, sCol)).Sort .[B4], 1, .[c4], , 1, Header:=xlNo
    aCH = .Range("A4:C" & eRow).Value
    For i = 4 To eRow
      Dic.Add .Range("A" & i).Text, i - 3
      If .Range("B" & i) <> .Range("B" & i - 1) Then
        fRow = i - 3: N = N + 1
        fRow2 = i - 3: N2 = N2 + 1
      ElseIf .Range("C" & i) <> .Range("C" & i - 1) Then
        fRow2 = i - 3: N2 = N2 + 1
      End If
      If .Range("B" & i) <> .Range("B" & i + 1) Then
        aRow(N, 1) = fRow: aRow(N, 2) = i - 3
        Dic.Add .Range("B" & i), N
        aRow(N2, 3) = fRow2: aRow(N2, 4) = i - 3
        Dic.Add .Range("B" & i) & .Range("C" & i), N2
      ElseIf .Range("C" & i) <> .Range("C" & i + 1) Then
        aRow(N2, 3) = fRow2: aRow(N2, 4) = i - 3
        Dic.Add .Range("B" & i) & .Range("C" & i), N2
      End If
    Next i

    sRow = UBound(aCH)
    For j = 4 To sCol Step 2
      mSP = .Cells(1, j).Value
      aTT = .Cells(4, j).Resize(sRow, 2).Value
      Tong = 0
      Call KhuVuc_Cum
      If Tong > 0 Then Call KhuVuc
      If Tong > 0 Then Call TatCa
      ReDim aTT(1 To sRow, 1 To 2)
      For i = 1 To sRow
        ik = Dic.Item(sArr(i, 1))
        aTT(ik, 1) = sArr(i, 4)
        aTT(ik, 2) = sArr(i, 5)
      Next i
      .Cells(4, j).Resize(sRow, 2) = aTT 'Gan ket qua
    Next j
  End With
  With Sheets("DIEU_CHUYEN") 'Gan ket qua
    .Range("F2").Resize(sRow, 5).Clear
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:D" & eRow).ClearContents
    If k Then
      .Range("A2:C2").Resize(k) = Res
      .Range("D2").Resize(k) = Res2
      MsgBox ("Done!")
    Else
      MsgBox ("Khong co San Pham dieu chuyen!")
    End If
  End With
  Application.ScreenUpdating = True
End Sub

Private Sub KhuVuc_Cum()
  Dim fRow&, eRow&
  With Sheets("DIEU_CHUYEN")
    .Range("F2").Resize(sRow).NumberFormat = "@"
    .Range("F2").Resize(sRow, 3) = aCH
    .Range("I2").Resize(sRow, 2) = aTT
    .Range("F2:J2").Resize(sRow).Sort .[I2], 2, .[J2], , 2, Header:=xlNo
    .Range("F2:J2").Resize(sRow).Sort .[G2], 1, .[H2], , 1, Header:=xlNo
    sArr = .Range("F2").Resize(sRow, 5).Value
  End With
  For q = 1 To N2
    fRow = aRow(q, 3): eRow = aRow(q, 4)
    Call Trung(fRow, eRow, True)
    Call KhongTrung(fRow, eRow)
  Next q
End Sub

Private Sub KhuVuc()
  Dim fRow&, eRow&
  With Sheets("DIEU_CHUYEN")
    .Range("F2").Resize(sRow, 5) = sArr
    .Range("F2:J2").Resize(sRow).Sort .[G2], 1, .[I2], , 2, .[J2], 2, Header:=xlNo
    sArr = .Range("F2").Resize(sRow, 5).Value
  End With
  For q = 1 To N
    fRow = aRow(q, 1): eRow = aRow(q, 2)
    Call Trung(fRow, eRow, False)
    Call KhongTrung(fRow, eRow)
  Next q
End Sub

Private Sub TatCa()
  Dim fRow&, eRow&
  With Sheets("DIEU_CHUYEN")
    .Range("F2").Resize(sRow, 5) = sArr
    .Range("F2:J2").Resize(sRow).Sort .[I2], 2, .[J2], , 2, Header:=xlNo
    sArr = .Range("F2").Resize(sRow, 5).Value
  End With
  For q = 1 To N
    fRow = 1: eRow = sRow
    Call Trung(fRow, eRow, False)
    Call KhongTrung(fRow, eRow)
  Next q
End Sub

Private Sub Trung(ByRef fRow, ByRef eRow, ByVal bTong As Boolean)
  Dim fRow2&
  fRow2 = fRow
  For i = fRow To eRow
    If bTong Then Tong = Tong + sArr(i, 5)
    If sArr(i, 4) > 0 Then
      For r = fRow2 To eRow
        If sArr(r, 5) > 0 Then
          If sArr(i, 4) = sArr(r, 5) Then
            k = k + 1
            Res(k, 1) = mSP:          Res(k, 2) = sArr(i, 1)
            Res(k, 3) = sArr(r, 1):   Res2(k, 1) = sArr(i, 4)
            sArr(i, 4) = 0:           sArr(r, 5) = 0
            If bTong Then Tong = Tong - sArr(r, 5)
            fRow2 = r + 1
            Exit For
          End If
        End If
      Next r
    End If
  Next i
End Sub

Private Sub KhongTrung(ByRef fRow, ByRef eRow)
  Dim fRow2&
  fRow2 = fRow
  For i = fRow To eRow
    If sArr(i, 4) > 0 Then
      For r = fRow2 To eRow
          If sArr(r, 5) > 0 Then
            k = k + 1
            Res(k, 1) = mSP: Res(k, 2) = sArr(i, 1): Res(k, 3) = sArr(r, 1)
            If sArr(i, 4) > sArr(r, 5) Then
              Res2(k, 1) = sArr(r, 5)
              sArr(i, 4) = sArr(i, 4) - sArr(r, 5)
              Tong = Tong - sArr(r, 5)
              sArr(r, 5) = 0
            Else
              Res2(k, 1) = sArr(i, 4)
              sArr(r, 5) = sArr(r, 5) - sArr(i, 4)
              Tong = Tong - sArr(i, 4)
              sArr(i, 4) = 0
              fRow2 = r:     Exit For
            End If
          End If
      Next r
    End If
  Next i
End Sub
Nhấp chuột vào đây để mở rộng...

Đúng như mình mong muốn rồi. Cám ơn bạn rất nhiều ^^
 
Upvote 0
HieuCD đã viết:
Kiểm tra lại
Mã: 
Dim aCH(), aTT(), sArr(), aRow(), Res() As String, Res2()
Dim mSP$, Tong#
Dim sRow&, N&, N2&, k&, i&, r&, q&, j&

Sub Main()
  Dim Dic As Object
  Dim fRow&, eRow&, fRow2&, sCol&, ik&
  Const rMax As String = 10000 'So dong ket qua toi da 10.000 dong

  ReDim Res(1 To rMax, 1 To 3)
  ReDim Res2(1 To rMax, 1 To 1)
  Set Dic = CreateObject("scripting.dictionary")
  ReDim aRow(1 To 1000, 1 To 4)
  N = 0: N2 = 0: k = 0

  Application.ScreenUpdating = False
  With Sheets("THUA_THIEU")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    sCol = .Cells(1, 16000).End(xlToLeft).Column
    .Range("A4", .Cells(eRow, sCol)).Sort .[B4], 1, .[c4], , 1, Header:=xlNo
    aCH = .Range("A4:C" & eRow).Value
    For i = 4 To eRow
      Dic.Add .Range("A" & i).Text, i - 3
      If .Range("B" & i) <> .Range("B" & i - 1) Then
        fRow = i - 3: N = N + 1
        fRow2 = i - 3: N2 = N2 + 1
      ElseIf .Range("C" & i) <> .Range("C" & i - 1) Then
        fRow2 = i - 3: N2 = N2 + 1
      End If
      If .Range("B" & i) <> .Range("B" & i + 1) Then
        aRow(N, 1) = fRow: aRow(N, 2) = i - 3
        Dic.Add .Range("B" & i), N
        aRow(N2, 3) = fRow2: aRow(N2, 4) = i - 3
        Dic.Add .Range("B" & i) & .Range("C" & i), N2
      ElseIf .Range("C" & i) <> .Range("C" & i + 1) Then
        aRow(N2, 3) = fRow2: aRow(N2, 4) = i - 3
        Dic.Add .Range("B" & i) & .Range("C" & i), N2
      End If
    Next i

    sRow = UBound(aCH)
    For j = 4 To sCol Step 2
      mSP = .Cells(1, j).Value
      aTT = .Cells(4, j).Resize(sRow, 2).Value
      Tong = 0
      Call KhuVuc_Cum
      If Tong > 0 Then Call KhuVuc
      If Tong > 0 Then Call TatCa
      ReDim aTT(1 To sRow, 1 To 2)
      For i = 1 To sRow
        ik = Dic.Item(sArr(i, 1))
        aTT(ik, 1) = sArr(i, 4)
        aTT(ik, 2) = sArr(i, 5)
      Next i
      .Cells(4, j).Resize(sRow, 2) = aTT 'Gan ket qua
    Next j
  End With
  With Sheets("DIEU_CHUYEN") 'Gan ket qua
    .Range("F2").Resize(sRow, 5).Clear
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:D" & eRow).ClearContents
    If k Then
      .Range("A2:C2").Resize(k) = Res
      .Range("D2").Resize(k) = Res2
      MsgBox ("Done!")
    Else
      MsgBox ("Khong co San Pham dieu chuyen!")
    End If
  End With
  Application.ScreenUpdating = True
End Sub

Private Sub KhuVuc_Cum()
  Dim fRow&, eRow&
  With Sheets("DIEU_CHUYEN")
    .Range("F2").Resize(sRow).NumberFormat = "@"
    .Range("F2").Resize(sRow, 3) = aCH
    .Range("I2").Resize(sRow, 2) = aTT
    .Range("F2:J2").Resize(sRow).Sort .[I2], 2, .[J2], , 2, Header:=xlNo
    .Range("F2:J2").Resize(sRow).Sort .[G2], 1, .[H2], , 1, Header:=xlNo
    sArr = .Range("F2").Resize(sRow, 5).Value
  End With
  For q = 1 To N2
    fRow = aRow(q, 3): eRow = aRow(q, 4)
    Call Trung(fRow, eRow, True)
    Call KhongTrung(fRow, eRow)
  Next q
End Sub

Private Sub KhuVuc()
  Dim fRow&, eRow&
  With Sheets("DIEU_CHUYEN")
    .Range("F2").Resize(sRow, 5) = sArr
    .Range("F2:J2").Resize(sRow).Sort .[G2], 1, .[I2], , 2, .[J2], 2, Header:=xlNo
    sArr = .Range("F2").Resize(sRow, 5).Value
  End With
  For q = 1 To N
    fRow = aRow(q, 1): eRow = aRow(q, 2)
    Call Trung(fRow, eRow, False)
    Call KhongTrung(fRow, eRow)
  Next q
End Sub

Private Sub TatCa()
  Dim fRow&, eRow&
  With Sheets("DIEU_CHUYEN")
    .Range("F2").Resize(sRow, 5) = sArr
    .Range("F2:J2").Resize(sRow).Sort .[I2], 2, .[J2], , 2, Header:=xlNo
    sArr = .Range("F2").Resize(sRow, 5).Value
  End With
  For q = 1 To N
    fRow = 1: eRow = sRow
    Call Trung(fRow, eRow, False)
    Call KhongTrung(fRow, eRow)
  Next q
End Sub

Private Sub Trung(ByRef fRow, ByRef eRow, ByVal bTong As Boolean)
  Dim fRow2&
  fRow2 = fRow
  For i = fRow To eRow
    If bTong Then Tong = Tong + sArr(i, 5)
    If sArr(i, 4) > 0 Then
      For r = fRow2 To eRow
        If sArr(r, 5) > 0 Then
          If sArr(i, 4) = sArr(r, 5) Then
            k = k + 1
            Res(k, 1) = mSP:          Res(k, 2) = sArr(i, 1)
            Res(k, 3) = sArr(r, 1):   Res2(k, 1) = sArr(i, 4)
            sArr(i, 4) = 0:           sArr(r, 5) = 0
            If bTong Then Tong = Tong - sArr(r, 5)
            fRow2 = r + 1
            Exit For
          End If
        End If
      Next r
    End If
  Next i
End Sub

Private Sub KhongTrung(ByRef fRow, ByRef eRow)
  Dim fRow2&
  fRow2 = fRow
  For i = fRow To eRow
    If sArr(i, 4) > 0 Then
      For r = fRow2 To eRow
          If sArr(r, 5) > 0 Then
            k = k + 1
            Res(k, 1) = mSP: Res(k, 2) = sArr(i, 1): Res(k, 3) = sArr(r, 1)
            If sArr(i, 4) > sArr(r, 5) Then
              Res2(k, 1) = sArr(r, 5)
              sArr(i, 4) = sArr(i, 4) - sArr(r, 5)
              Tong = Tong - sArr(r, 5)
              sArr(r, 5) = 0
            Else
              Res2(k, 1) = sArr(i, 4)
              sArr(r, 5) = sArr(r, 5) - sArr(i, 4)
              Tong = Tong - sArr(i, 4)
              sArr(i, 4) = 0
              fRow2 = r:     Exit For
            End If
          End If
      Next r
    End If
  Next i
End Sub
Nhấp chuột vào đây để mở rộng...

Bạn ơi. Code này mình chạy cho file khác sao nó hổng ra.
Phiền bạn xem lại giùm mình với
 

File đính kèm

Upvote 0
Quỳnh Như 7648 đã viết:
Bạn ơi. Code này mình chạy cho file khác sao nó hổng ra.
Phiền bạn xem lại giùm mình với
Nhấp chuột vào đây để mở rộng...
Dạng dữ liệu CH bị thay đổi. Chỉnh code
ik = Dic.Item(CStr(sArr(i, 1)))
Mã: 
Sub Main()
  Dim Dic As Object
  Dim fRow&, eRow&, fRow2&, sCol&, ik&
  Const rMax As String = 10000 'So dong ket qua toi da 10.000 dong

  ReDim Res(1 To rMax, 1 To 3)
  ReDim Res2(1 To rMax, 1 To 1)
  Set Dic = CreateObject("scripting.dictionary")
  ReDim aRow(1 To 1000, 1 To 4)
  N = 0: N2 = 0: k = 0
 
  Application.ScreenUpdating = False
  With Sheets("THUA_THIEU")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    sCol = .Cells(1, 16000).End(xlToLeft).Column
    .Range("A4", .Cells(eRow, sCol)).Sort .[B4], 1, .[c4], , 1, Header:=xlNo
    aCH = .Range("A4:C" & eRow).Value
    For i = 4 To eRow
      Dic.Add .Range("A" & i).Text, i - 3
      If .Range("B" & i) <> .Range("B" & i - 1) Then
        fRow = i - 3: N = N + 1
        fRow2 = i - 3: N2 = N2 + 1
      ElseIf .Range("C" & i) <> .Range("C" & i - 1) Then
        fRow2 = i - 3: N2 = N2 + 1
      End If
      If .Range("B" & i) <> .Range("B" & i + 1) Then
        aRow(N, 1) = fRow: aRow(N, 2) = i - 3
        Dic.Add .Range("B" & i), N
        aRow(N2, 3) = fRow2: aRow(N2, 4) = i - 3
        Dic.Add .Range("B" & i) & .Range("C" & i), N2
      ElseIf .Range("C" & i) <> .Range("C" & i + 1) Then
        aRow(N2, 3) = fRow2: aRow(N2, 4) = i - 3
        Dic.Add .Range("B" & i) & .Range("C" & i), N2
      End If
    Next i
 
    sRow = UBound(aCH)
    For j = 4 To sCol Step 2
      mSP = .Cells(1, j).Value
      aTT = .Cells(4, j).Resize(sRow, 2).Value
      Tong = 0
      Call KhuVuc_Cum
      If Tong > 0 Then Call KhuVuc
      If Tong > 0 Then Call TatCa
      ReDim aTT(1 To sRow, 1 To 2)
      For i = 1 To sRow
        ik = Dic.Item(CStr(sArr(i, 1)))
        aTT(ik, 1) = sArr(i, 4)
        aTT(ik, 2) = sArr(i, 5)
      Next i
      .Cells(4, j).Resize(sRow, 2) = aTT 'Gan ket qua
    Next j
  End With
  With Sheets("DIEU_CHUYEN") 'Gan ket qua
    .Range("F2").Resize(sRow, 5).Clear
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:D" & eRow).ClearContents
    If k Then
      .Range("A2:C2").Resize(k) = Res
      .Range("D2").Resize(k) = Res2
      MsgBox ("Done!")
    Else
      MsgBox ("Khong co San Pham dieu chuyen!")
    End If
  End With
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
Dạng dữ liệu CH bị thay đổi. Chỉnh code
ik = Dic.Item(CStr(sArr(i, 1)))
Mã: 
Sub Main()
  Dim Dic As Object
  Dim fRow&, eRow&, fRow2&, sCol&, ik&
  Const rMax As String = 10000 'So dong ket qua toi da 10.000 dong

  ReDim Res(1 To rMax, 1 To 3)
  ReDim Res2(1 To rMax, 1 To 1)
  Set Dic = CreateObject("scripting.dictionary")
  ReDim aRow(1 To 1000, 1 To 4)
  N = 0: N2 = 0: k = 0

  Application.ScreenUpdating = False
  With Sheets("THUA_THIEU")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    sCol = .Cells(1, 16000).End(xlToLeft).Column
    .Range("A4", .Cells(eRow, sCol)).Sort .[B4], 1, .[c4], , 1, Header:=xlNo
    aCH = .Range("A4:C" & eRow).Value
    For i = 4 To eRow
      Dic.Add .Range("A" & i).Text, i - 3
      If .Range("B" & i) <> .Range("B" & i - 1) Then
        fRow = i - 3: N = N + 1
        fRow2 = i - 3: N2 = N2 + 1
      ElseIf .Range("C" & i) <> .Range("C" & i - 1) Then
        fRow2 = i - 3: N2 = N2 + 1
      End If
      If .Range("B" & i) <> .Range("B" & i + 1) Then
        aRow(N, 1) = fRow: aRow(N, 2) = i - 3
        Dic.Add .Range("B" & i), N
        aRow(N2, 3) = fRow2: aRow(N2, 4) = i - 3
        Dic.Add .Range("B" & i) & .Range("C" & i), N2
      ElseIf .Range("C" & i) <> .Range("C" & i + 1) Then
        aRow(N2, 3) = fRow2: aRow(N2, 4) = i - 3
        Dic.Add .Range("B" & i) & .Range("C" & i), N2
      End If
    Next i

    sRow = UBound(aCH)
    For j = 4 To sCol Step 2
      mSP = .Cells(1, j).Value
      aTT = .Cells(4, j).Resize(sRow, 2).Value
      Tong = 0
      Call KhuVuc_Cum
      If Tong > 0 Then Call KhuVuc
      If Tong > 0 Then Call TatCa
      ReDim aTT(1 To sRow, 1 To 2)
      For i = 1 To sRow
        ik = Dic.Item(CStr(sArr(i, 1)))
        aTT(ik, 1) = sArr(i, 4)
        aTT(ik, 2) = sArr(i, 5)
      Next i
      .Cells(4, j).Resize(sRow, 2) = aTT 'Gan ket qua
    Next j
  End With
  With Sheets("DIEU_CHUYEN") 'Gan ket qua
    .Range("F2").Resize(sRow, 5).Clear
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:D" & eRow).ClearContents
    If k Then
      .Range("A2:C2").Resize(k) = Res
      .Range("D2").Resize(k) = Res2
      MsgBox ("Done!")
    Else
      MsgBox ("Khong co San Pham dieu chuyen!")
    End If
  End With
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cam ơn bạn rất nhiều
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

SA_DQ
  • Question Question
[Bài tập VBA cho người rỗi rảnh] Hãy viết 1 macro tìm ra 3 số nguyên tố liên tiếp
2
Trả lời
27
Đọc
521
VetMini
V
T
Định dạng cột dữ liệu trong sql
Trả lời
0
Đọc
28
tuanxitin
T
L
  • Question Question
[Hlep] Xóa ảnh theo tên và kích thước
Trả lời
8
Đọc
158
Luong24
L
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
0
Đọc
54
Xoainon3005
Xoainon3005
A
Tạo vé Loto bằng Excel
Trả lời
19
Đọc
23K
vinhquang14292
vinhquang14292
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
14 15 16
Trả lời
308
Đọc
22K
CheezeTube
CheezeTube
Akingee
Món quà tuyệt vời thứ 2 của Cloudflare dành cho nhân loại - WARP
Trả lời
0
Đọc
80
Akingee
Akingee
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
74
Đọc
10K
vn72259
V
H
Vì sao trong khi cộng và khi sum lại hiển thị sai
Trả lời
15
Đọc
57K
hieung99
hieung99
Thanh271188
Tìm giá trị xuất hiện bất kì (không phải giá trị đầu, cuối) trong excel
    • Cười
Trả lời
3
Đọc
138
VetMini
V
T
Nhờ hỗ trợ hàm SUMIF không phân biệt được các ký tự "0" trước một số trong chuỗi
Trả lời
3
Đọc
187
tan10ckn
T
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2 3
Trả lời
46
Đọc
14K
tuantran203
T
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
260
Đọc
27K
hoangtuan.net
hoangtuan.net
HeSanbi
  • Đã giải quyết
WeatherXL - Ứng dụng lấy dữ liệu Thời tiết siêu nhanh (*15/01/2024)
    • Thích
    • Yêu thích
3 4 5
Trả lời
88
Đọc
19K
vc_đi chơi
vc_đi chơi
L
[Help] tự động lấy dữ liệu cổ phiếu từ vietstock về file excel
    • Thích
Trả lời
3
Đọc
848
ketoan113
K
N
Tách chuỗi và tìm kiếm theo dữ liệu gần đúng trong chuỗi ký tự
Trả lời
8
Đọc
205
Ngocminh19
N
Mr.hieudoanxd
  • Question Question
[Cần hướng dẫn] Về lập trình Viết Function với Settimer và Killtimer
    • Thích
Trả lời
8
Đọc
347
nguyendang95
N
P
Các Bác cho e hỏi làm thế nào để ẩn công thức trên GOOGLE SHEET với ạ?
2
Trả lời
21
Đọc
18K
học excel googlesheet
học excel googlesheet
Emyeuexcel
  • Question Question
Code VBA mở nhiều file, value các sheet, lưu và đóng file
Trả lời
3
Đọc
147
Emyeuexcel
Emyeuexcel
V
Cho 2 biến - kết quả trả về giá trị của hàng đầu tiên
    • Chấp nhận
Trả lời
5
Đọc
180
Duy Tùng 9x
Duy Tùng 9x
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom