[Nhờ giúp] Ghép dữ liệu các cell theo điều kiện (1 người xem)

mrbtuan · 6/1/17

Chào các anh chị.
Em có vấn đề với báo cáo trước giờ làm bằng tay, mà giờ em muốn làm excel nhanh hơn nhưng chưa nghĩ ra phương án mong anh chị giúp.

Em có file chứa 3 cột
Mã hàng chung/ Số hộp/ Số lượng

Giờ em muốn tạo một báo cáo với 2 cột mới
Mã hàng/ Chi tiết hộp với nội dung như sau:
Mã hàng lấy dữ liệu từ cột Mã hàng chung- loại trừ đi các giá trị trùng lặp
Với mỗi Mã hàng thì em muốn ghép Các "Số hộp" với "Số lượng" vào một cell mới tương ứng
Mã hàng= Sohop01(Soluong01), Sohop02(Soluong02), Sohop03(Soluong03)..
Nếu số lượng trong mỗi hộp như soluong01, soluong02.. trùng nhau và sohop01, sohop02.. là các số trong dãy số liên tiếp thì em muốn rút gọn thành
Mã hàng= sohop01-sohop02(soluong01)
Em gửi theo file giải thích chi tiết.
Mong anh chị giúp đỡ.

HieuCD · 6/1/17

mrbtuan đã viết:
Chào các anh chị.
Em có vấn đề với báo cáo trước giờ làm bằng tay, mà giờ em muốn làm excel nhanh hơn nhưng chưa nghĩ ra phương án mong anh chị giúp.

Em có file chứa 3 cột
Mã hàng chung/ Số hộp/ Số lượng

Giờ em muốn tạo một báo cáo với 2 cột mới
Mã hàng/ Chi tiết hộp với nội dung như sau:
Mã hàng lấy dữ liệu từ cột Mã hàng chung- loại trừ đi các giá trị trùng lặp
Với mỗi Mã hàng thì em muốn ghép Các "Số hộp" với "Số lượng" vào một cell mới tương ứng
Mã hàng= Sohop01(Soluong01), Sohop02(Soluong02), Sohop03(Soluong03)..
Nếu số lượng trong mỗi hộp như soluong01, soluong02.. trùng nhau và sohop01, sohop02.. là các số trong dãy số liên tiếp thì em muốn rút gọn thành
Mã hàng= sohop01-sohop02(soluong01)
Em gửi theo file giải thích chi tiết.
Mong anh chị giúp đỡ.

bạn xem lại file trường hợp
81(3),43(6),215(10),132(3),45(5),44(6)
45(5) có SL là 5 sao ghép được?

mrbtuan · 6/1/17

Cám ơn anh đã xem giúp em.
Đoạn đó em để ví dụ nhầm. Em đã sửa lại file.
81(3),43(6),215(10),45(6),44(6)

Bình thường em làm bằng tay nên với dữ liệu lớn thì em làm rất lâu.
Mong anh xem lại giúp.

HieuCD · 6/1/17

mrbtuan đã viết:
Cám ơn anh đã xem giúp em.
Đoạn đó em để ví dụ nhầm. Em đã sửa lại file.
81(3),43(6),215(10),45(6),44(6)

Bình thường em làm bằng tay nên với dữ liệu lớn thì em làm rất lâu.
Mong anh xem lại giúp.

bạn chạy thử code

Mã:

Sub GPE()
Dim Arr(), D(), i As Long, k As Long
D = Range("A2:C" & Range("A65500").End(xlUp).Row).Value
Range("S2").Resize(UBound(D), 3) = D
Range("S2").Resize(UBound(D), 3).Sort [S2], 1, [T2], Order2:=1, Key3:=[U2], Order3:=1, Header:=xlNo
D = Range("S1").Resize(UBound(D) + 2, 4).Value
ReDim Arr(1 To UBound(D), 1 To 2)
Range("S2").Resize(UBound(D), 3).ClearContents
Range("N2").Resize(1000, 2).ClearContents
For i = 2 To UBound(D) - 1
  If (D(i, 1) <> D(i - 1, 1) Or D(i, 2) <> D(i - 1, 2) + 1) And D(i, 1) = D(i + 1, 1) _
        And D(i, 2) = D(i + 1, 2) - 1 And D(i, 3) = D(i + 1, 3) Then
    D(i, 4) = "d"
  ElseIf (D(i - 1, 4) = "d" Or D(i - 1, 4) = "t") And D(i, 1) = D(i + 1, 1) _
      And D(i, 2) = D(i + 1, 2) - 1 And D(i, 3) = D(i + 1, 3) Then
    D(i, 4) = "t"
  ElseIf (D(i - 1, 4) = "d" Or D(i - 1, 4) = "t") And (D(i, 1) <> D(i + 1, 1) _
      Or D(i, 2) <> D(i + 1, 2) - 1 Or D(i, 3) <> D(i + 1, 3)) Then
    D(i, 4) = "c"
  Else
    D(i, 4) = "r"
  End If
Next i
For i = 2 To UBound(D) - 1
  If D(i, 1) <> D(i - 1, 1) Then
    k = k + 1
    Arr(k, 1) = D(i, 1)
    Arr(k, 2) = D(i, 2) & IIf(D(i, 4) = "d", "", "(" & D(i, 3) & ")")
  Else
    If D(i, 4) = "c" Then
      Arr(k, 2) = Arr(k, 2) & "-" & D(i, 2) & "(" & D(i, 3) & ")"
    ElseIf D(i, 4) = "r" Then
      Arr(k, 2) = Arr(k, 2) & "," & D(i, 2) & "(" & D(i, 3) & ")"
    ElseIf D(i, 4) = "d" Then
      Arr(k, 2) = Arr(k, 2) & "," & D(i, 2)
    End If
  End If
Next i
Range("N2").Resize(k, 2) = Arr
End Sub

befaint · 6/1/17

Tuyệt vời đó anh HieuCD ơi! }}}}}

Em đang nghĩ cách làm trên mảng mà hoa mắt quá -+*/

HieuCD · 6/1/17

befaint đã viết:
Tuyệt vời đó anh HieuCD ơi!

Em đang nghĩ cách làm trên mảng mà hoa mắt quá

cám ơn bạn, mình cũng đâu có tưởng tượng được giá trị các mảng, bài nầy mình phải xuất ra từng đoạn rồi làm tay thử rồi mới ráp từ từ }}}}}

befaint · 7/1/17

HieuCD đã viết:
cám ơn bạn, mình cũng đâu có tưởng tượng được giá trị các mảng, bài nầy mình phải xuất ra từng đoạn rồi làm tay thử rồi mới ráp từ từ

Mần mớ đó kinh quá, }}}}}

không dám dán code ra bài luôn --=0

Anh ngó qua giúp em với.

mrbtuan · 7/1/17

Cảm ơn anh, em chạy file đó được rồi. Từ giờ đỡ phải mất cả buổi sáng làm cái này nữa.
Chân thành cảm ơn anh.

HieuCD · 7/1/17

befaint đã viết:
Mần mớ đó kinh quá, không dám dán code ra bài luôn

Anh ngó qua giúp em với.

dữ liệu chưa sort trước mà bạn xử lý được là quá giỏi, hàng loạt biến số đan xen nhau không dể gì giải quyết }}}}}

đọc code của bạn mình cũng không không hiểu lắm, làm thử lung tung thì thấy có lẽ nên thêm dấu bằng vào dòng lệnh sau để mã 25100-84100 chạy đủ kết quả
chúc bạn một tối vui

Mã:

Public Function NoiHL(tmp As Variant, so) As Variant
Dim z As Integer
Dim T(), t1 As Integer, y As Integer, x As Integer
Dim ck As Boolean
z = UBound(tmp)
ReDim T(1 To z)
For x = 1 To z - 1
    ck = False
    If x <[COLOR=#ff0000]=[/COLOR] y Then GoTo 1

befaint · 7/1/17

HieuCD đã viết:
dữ liệu chưa sort trước mà bạn xử lý được là quá giỏi, hàng loạt biến số đan xen nhau không dể gì giải quyết
đọc code của bạn mình cũng không không hiểu lắm, làm thử lung tung thì thấy có lẽ nên thêm dấu bằng vào dòng lệnh sau để mã 25100-84100 chạy đủ kết quả
chúc bạn một tối vui

Mã:

Public Function NoiHL(tmp As Variant, so) As Variant Dim z As Integer Dim T(), t1 As Integer, y As Integer, x As Integer Dim ck As Boolean z = UBound(tmp) ReDim T(1 To z) For x = 1 To z - 1 ck = False If x <[COLOR=#ff0000]=[/COLOR] y Then GoTo 1

Tốt quá! Có anh kiểm tra giúp. Em hóng anh mãi không thấy...

Hàm đó để nối các hộp có cùng số lượng của một mã. Chỉnh như anh nêu thì chưa được, sẽ bị lỗi các trường hợp khác. Em làm còn sót trường hợp này. --=0

Cảm ơn anh!

HieuCD · 7/1/17

befaint đã viết:
Tốt quá! Có anh kiểm tra giúp. Em hóng anh mãi không thấy...

Hàm đó để nối các hộp có cùng số lượng của một mã. Chỉnh như anh nêu thì chưa được, sẽ bị lỗi các trường hợp khác. Em làm còn sót trường hợp này.

Cảm ơn anh!

mình kiểm tra không kỷ nên đúng là bị lỗi chổ khác, code mình viết kiểm tra lại thiếu 1 điều kiện nên cũng có 1 trường hợp chạy không chuẩn, cũng phải sửa lại. Bài nầy coi vậy mà cũng phức tạp thiệt

Mã:

Sub GPE()
Dim Arr(), D(), i As Long, k As Long
D = Range("A2:C" & Range("A65500").End(xlUp).Row).Value
Range("S2").Resize(UBound(D), 3) = D
Range("S2").Resize(UBound(D), 3).Sort [S2], 1, [T2], Order2:=1, Key3:=[U2], Order3:=1, Header:=xlNo
D = Range("S1").Resize(UBound(D) + 2, 4).Value
ReDim Arr(1 To UBound(D), 1 To 2)
Range("S2").Resize(UBound(D), 3).ClearContents
Range("N2").Resize(1000, 2).ClearContents

For i = 2 To UBound(D) - 1
  If (D(i, 1) <> D(i - 1, 1) Or D(i, 2) <> D(i - 1, 2) + 1 [COLOR=#ff0000]Or D(i, 3) <> D(i - 1, 3)[/COLOR]) And D(i, 1) = D(i + 1, 1) _
        And D(i, 2) = D(i + 1, 2) - 1 And D(i, 3) = D(i + 1, 3) Then
    D(i, 4) = "d"
  ElseIf (D(i - 1, 4) = "d" Or D(i - 1, 4) = "t") And D(i, 1) = D(i + 1, 1) _
      And D(i, 2) = D(i + 1, 2) - 1 And D(i, 3) = D(i + 1, 3) Then
    D(i, 4) = "t"
  ElseIf (D(i - 1, 4) = "d" Or D(i - 1, 4) = "t") And (D(i, 1) <> D(i + 1, 1) _
      Or D(i, 2) <> D(i + 1, 2) - 1 Or D(i, 3) <> D(i + 1, 3)) Then
    D(i, 4) = "c"
  Else
    D(i, 4) = "r"
  End If
Next i

For i = 2 To UBound(D) - 1
  If D(i, 1) <> D(i - 1, 1) Then
    k = k + 1
    Arr(k, 1) = D(i, 1)
    Arr(k, 2) = D(i, 2) & IIf(D(i, 4) = "d", "", "(" & D(i, 3) & ")")
  Else
    If D(i, 4) = "c" Then
      Arr(k, 2) = Arr(k, 2) & "-" & D(i, 2) & "(" & D(i, 3) & ")"
    ElseIf D(i, 4) = "r" Then
      Arr(k, 2) = Arr(k, 2) & "," & D(i, 2) & "(" & D(i, 3) & ")"
    ElseIf D(i, 4) = "d" Then
      Arr(k, 2) = Arr(k, 2) & "," & D(i, 2)
    End If
  End If
Next i
Range("N2").Resize(k, 2) = Arr
End Sub

befaint · 7/1/17

HieuCD đã viết:
mình kiểm tra không kỷ nên đúng là bị lỗi chổ khác, code mình viết kiểm tra lại thiếu 1 điều kiện nên cũng có 1 trường hợp chạy không chuẩn, cũng phải sửa lại. Bài nầy coi vậy mà cũng phức tạp thiệt

Cũng mất kha khá thời gian anh.

Em so kết quả bài của em với bài của anh thấy ổn ổn nên cũng gửi bài theo --=0

Để mai xem lại vậy.

Khò khò thôi anh --=--

--------------------
Em đã sửa lại chỗ lỗi đó... Anh xem giúp em với nhé.

doveandrose · 9/1/17

Xong phần của thớt thì sẽ tới nội dung dành cho các thanh niên thích đùa --=0

Mã:

Public Sub hello()
Dim arr, i As Long, k As Long, r As Long, rng As Range, dic As Object
Dim tpKey, tmp, mRow As String, dArr(1 To 100000, 1 To 2)


Set dic = CreateObject("scripting.dictionary")
With Sheet1
    arr = .Range("A2:C" & .[A100000].End(xlUp).Row).Value
    For r = 1 To UBound(arr) Step 1
        dic(arr(r, 1)) = dic(arr(r, 1)) & "," & Split(Cells(1, arr(r, 3)).Address(1, 0), "$")(0) & arr(r, 2)
    Next
    
    For Each tpKey In dic.keys
        Set rng = Range(Mid(dic(tpKey), 2))
        tmp = Split(Intersect(rng, rng).Address(0, 0), ",")
        For i = 0 To UBound(tmp) Step 1
            mRow = IIf(InStr(tmp(i), ":") > 0, Range(tmp(i)).EntireRow.Address(0, 0), Range(tmp(i)).Row)
            tmp(i) = mRow & "(" & Range(tmp(i)).Column & ")"
        Next
        k = k + 1
        dArr(k, 1) = tpKey
        dArr(k, 2) = Replace(Join(tmp, ","), ":", "-")
    Next
    .Range("R2").Resize(100000, 2).ClearContents
    .Range("R2").Resize(k, 2).Value = dArr
End With
End Sub

HieuCD · 9/1/17

befaint đã viết:
Cũng mất kha khá thời gian anh.
Em so kết quả bài của em với bài của anh thấy ổn ổn nên cũng gửi bài theo
Để mai xem lại vậy.
Khò khò thôi anh

--------------------
Em đã sửa lại chỗ lỗi đó... Anh xem giúp em với nhé.

mình đã chạy thử rất chuẩn, chúc bạn một ngày vui }}}}}

doveandrose đã viết:

Xong phần của thớt thì sẽ tới nội dung dành cho các thanh niên thích đùa --=0

Mã:

Public Sub hello()
Dim arr, i As Long, k As Long, r As Long, rng As Range, dic As Object
Dim tpKey, tmp, mRow As String, dArr(1 To 100000, 1 To 2)
Set dic = CreateObject("scripting.dictionary")
With Sheet1
    arr = .Range("A2:C" & .[A100000].End(xlUp).Row).Value
    For r = 1 To UBound(arr) Step 1
        dic(arr(r, 1)) = dic(arr(r, 1)) & "," & Split(Cells(1, arr(r, 3)).Address(1, 0), "$")(0) & arr(r, 2)
    Next
    
    For Each tpKey In dic.keys
        Set rng = Range(Mid(dic(tpKey), 2))
        tmp = Split(Intersect(rng, rng).Address(0, 0), ",")
        For i = 0 To UBound(tmp) Step 1
            mRow = IIf(InStr(tmp(i), ":") > 0, Range(tmp(i)).EntireRow.Address(0, 0), Range(tmp(i)).Row)
            tmp(i) = mRow & "(" & Range(tmp(i)).Column & ")"
        Next
        k = k + 1
        dArr(k, 1) = tpKey
        dArr(k, 2) = Replace(Join(tmp, ","), ":", "-")
    Next
    .Range("R2").Resize(100000, 2).ClearContents
    .Range("R2").Resize(k, 2).Value = dArr
End With
End Sub

Đúng là chuyên gia có khác, code quá độc không thể tưởng tượng
Sau nầy doanh nghiệp làm ăn phát đạt, đóng thùng hàng khủng khoảng 17000 sản phẩm, lúc đó Microsoft chắc phải phát hành bản Office mới để theo kịp code của bạn, nếu không sẽ bị các công ty khác giành phần mất @!##

befaint · 9/1/17

HieuCD đã viết:
mình đã chạy thử rất chuẩn, chúc bạn một ngày vui

Đúng là chuyên gia có khác, code quá độc không thể tưởng tượng
Sau nầy doanh nghiệp làm ăn phát đạt, đóng thùng hàng khủng khoảng 17000 sản phẩm, lúc đó Microsoft chắc phải phát hành bản Office mới để theo kịp code của bạn, nếu không sẽ bị các công ty khác giành phần mất

Cảm ơn anh! }}}}}

Bài #13 thì code quá "ngầu"!! ọc ọc.... }}}}}

Em xì pam tẹo: Chưa tới 17000 đâu anh, 16384+1 thôi.

[Nhờ giúp] Ghép dữ liệu các cell theo điều kiện (1 người xem)

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

Thành viên mới

File đính kèm

Chuyên gia GPE

Thành viên mới

File đính kèm

Chuyên gia GPE

File đính kèm

|||||||||||||

Chuyên gia GPE

|||||||||||||

File đính kèm

Thành viên mới

Chuyên gia GPE

|||||||||||||

Chuyên gia GPE

|||||||||||||

File đính kèm

hello

Chuyên gia GPE

File đính kèm

|||||||||||||

Đếm ngược thời gian