huonglien1901
GPE là ngôi nhà thứ 2 của tôi!!!
- Tham gia
- 17/4/16
- Bài viết
- 2,701
- Được thích
- 2,434
- Giới tính
- Nam
- Nghề nghiệp
- Nhân viên kỹ thuật in ấn
Em chào mọi người!
Em có vấn đề nhờ mọi người hỗ trợ.
Em có đoạn code này:
Code này sẽ gộp chung nếu mã nhà cung cấp , tình trạng(Status), Tên nhà cung cấp, mã hợp đồng(M.....) trùng nhau và số đơn hàng khác nhau.
Code khi chạy nó gộp chung lại.
Trong sheet VD em có làm ví dụ mẫu.
Em muốn tách ra như thế này!
Số Order No 1923030809666
Số Order No 1923030809685
Em nhờ mọi người chỉnh sửa!
Em cảm ơn mọi người nhiều!
Em có vấn đề nhờ mọi người hỗ trợ.
Em có đoạn code này:
PHP:
Dim aMOQ, aLGH, aGIOCOLLECT, aLDH
Private Sub Worksheet_Change(ByVal Target As Range)
Dim eRow As Long, supBln As Boolean, Rng As Range
If Target.Address(0, 0) = "A3" Or Target.Address(0, 0) = "B1" Then
Call TangToc(False)
eRow = Range("A" & Rows.Count).End(xlUp).Row
If eRow > 4 Then Range("A5:K" & eRow).Clear
Call LungTung
Call TangToc(True)
End If
End Sub
Private Sub LungTung()
Dim sArr(), cArr(), Res(), S, colArr
Dim i As Long, eRow As Long, sRow As Long, k As Long
Dim Contract As String, Stastus As String, iKey
With Sheets("Car order")
cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
End With
With Sheets("CAR proposal")
sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
End With
sRow = UBound(sArr)
With CreateObject("scripting.dictionary")
For i = 1 To UBound(cArr)
iKey = cArr(i, 1)
If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
Next i
For i = 1 To sRow
iKey = sArr(i, 1)
If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
Next i
End With
Stastus = UCase(Left(Range("B1").Value, 3))
Contract = UCase(Range("A3").Value) & "*"
With CreateObject("scripting.dictionary")
For i = 1 To sRow
If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
If UCase(sArr(i, 4)) Like Contract Then
iKey = sArr(i, 2)
If .exists(iKey) = False Then
k = k + 1
.Add iKey, Array(i)
Else
S = .Item(iKey)
ReDim Preserve S(0 To UBound(S) + 1)
S(UBound(S)) = i
.Item(iKey) = S
End If
End If
End If
Next i
If k Then
If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
k = 0
For Each iKey In .keys
eRow = Range("A" & Rows.Count).End(xlUp).Row
k = k + 1
If k > 1 Then
Range("A1:K4").Copy
Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
eRow = eRow + 4
End If
Range("C" & eRow - 1) = iKey
Set Rng = Range("D" & eRow - 1).Resize(, 8)
Rng.ClearContents
Call Dong_3(Rng, iKey)
S = .Item(iKey)
ReDim Res(0 To UBound(S), 1 To UBound(colArr))
For n = 0 To UBound(S)
If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)
For j = 1 To UBound(colArr)
Res(n, j) = sArr(S(n), colArr(j))
Next j
Next n
Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
Next
eRow = Range("A" & Rows.Count).End(xlUp).Row
Range("E3:F" & eRow).NumberFormat = "#,###;[red](#,###);"
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
End If
End With
End Sub
Private Sub CreateArr_DuLieuTimkiem()
Dim wb As Workbook, eRow As Long
Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
With wb.Sheets("MOQ")
If .AutoFilterMode = True Then .AutoFilterMode = False
eRow = .Range("B" & Rows.Count).End(xlUp).Row
If eRow > 1 Then aMOQ = .Range("B2:H" & eRow).Value
End With
With wb.Sheets("LGH")
If .AutoFilterMode = True Then .AutoFilterMode = False
eRow = .Range("B" & Rows.Count).End(xlUp).Row
If eRow > 1 Then aLGH = .Range("B2:I" & eRow).Value
End With
With wb.Sheets("GIO COLLECT")
If .AutoFilterMode = True Then .AutoFilterMode = False
eRow = .Range("A" & Rows.Count).End(xlUp).Row
If eRow > 1 Then aGIOCOLLECT = .Range("A2:C" & eRow).Value
End With
With wb.Sheets("LDH")
If .AutoFilterMode = True Then .AutoFilterMode = False
eRow = .Range("B" & Rows.Count).End(xlUp).Row
If eRow > 1 Then aLDH = .Range("B2:P" & eRow).Value
End With
wb.Close False
End Sub
Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
Dim wb As Workbook, sArr()
Dim i As Long, eRow As Long, sRow As Long
sArr = aMOQ
sRow = UBound(sArr)
For i = 1 To sRow
If sArr(i, 1) = iKey Then
If Len(sArr(i, 4)) > 0 Then
Rng(1, 1) = sArr(i, 4)
ElseIf Len(sArr(i, 7)) > 0 Then
Rng(1, 1) = sArr(i, 7)
End If
If Len(sArr(i, 3)) > 0 Then
Rng(1, 2) = sArr(i, 3)
ElseIf Len(sArr(i, 5)) > 0 Then
Rng(1, 2) = sArr(i, 5)
End If
Exit For
End If
Next i
sArr = aLGH
sRow = UBound(sArr)
For i = 1 To sRow
If sArr(i, 1) = iKey Then
If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
Exit For
End If
Next i
sArr = aGIOCOLLECT
sRow = UBound(sArr)
For i = 1 To sRow
If sArr(i, 1) = iKey Then
If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
Exit For
End If
Next i
sArr = aLDH
sRow = UBound(sArr)
For i = 1 To sRow
If sArr(i, 1) = iKey Then
If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
Exit For
End If
Next i
End Sub
Private Sub TangToc(ByVal Bln As Boolean)
Application.EnableEvents = Bln
Application.ScreenUpdating = Bln
End SubCode khi chạy nó gộp chung lại.
Trong sheet VD em có làm ví dụ mẫu.
Em muốn tách ra như thế này!
Số Order No 1923030809666
Số Order No 1923030809685
Em nhờ mọi người chỉnh sửa!
Em cảm ơn mọi người nhiều!
Lần chỉnh sửa cuối:
