Lọc dữ liệu trùng và tính tổng (3 người xem)

[mhieuit]

Thân chào các anh chị GPE,
Em có 1 vấn đề nho nhỏ sau cần sự trợ giúp từ GPE:
- Anh/Chị dùng công thức hoặc code VBA để lọc dữ liệu và tính tổng qua sheet khác.
- Trong file đính kèm Sheet BTB form là kết quả, dữ liệu nguồn là sheet Report.
-Quá trình em làm bằng thủ công để có kết quả sheet BTB form:
+ Sheet Report: Tại cột M em lọc những location bắt đầu là O copy qua sheet BTB form, copy lần lượt dữ liệu tương ứng các cột P, Q, R qua sheet BTB form, sau đó em dùng chức năng Remove Duplicate để lọc bỏ giá trị trùng của Location (cột B sheet BTB form).
+Sheet BTB form: tại cột F em dùng hàm sumif để tính tổng dựa vào điều kiện Location (cột B sheet BTB form) để lấy giá trị bên sheet Report.

Mong Anh/Chị có thể giúp em vấn đề trên.
Em cám ơn!

 

[Ba Tê]

Thân chào các anh chị GPE,
Em có 1 vấn đề nho nhỏ sau cần sự trợ giúp từ GPE:
- Anh/Chị dùng công thức hoặc code VBA để lọc dữ liệu và tính tổng qua sheet khác.
- Trong file đính kèm Sheet BTB form là kết quả, dữ liệu nguồn là sheet Report.
-Quá trình em làm bằng thủ công để có kết quả sheet BTB form:
+ Sheet Report: Tại cột M em lọc những location bắt đầu là O copy qua sheet BTB form, copy lần lượt dữ liệu tương ứng các cột P, Q, R qua sheet BTB form, sau đó em dùng chức năng Remove Duplicate để lọc bỏ giá trị trùng của Location (cột B sheet BTB form).
+Sheet BTB form: tại cột F em dùng hàm sumif để tính tổng dựa vào điều kiện Location (cột B sheet BTB form) để lấy giá trị bên sheet Report.

Mong Anh/Chị có thể giúp em vấn đề trên.
Em cám ơn!

Sửa tên sheet Bin to Bin gì đó thành "GPE_1" cho gọn rồi chạy code này thử xem sao
[GPECODE=vb]Public Sub GPex()
Dim Dic As Object, sArr1(), sArr2(), dArr(), I As Long, J As Long, K As Long, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Report")
sArr1 = .Range(.[M2], .[M65536].End(xlUp)).Resize(, 6).Value2
sArr2 = .Range(.[M2], .[M65536].End(xlUp)).Offset(, 37).Value2
End With
ReDim dArr(1 To UBound(sArr1, 1), 1 To 9)
For I = 1 To UBound(sArr1, 1)
If Left(sArr1(I, 1), 1) = "O" Then
Tem = sArr1(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1: dArr(K, 1) = K
Dic.Add Tem, K
dArr(K, 2) = sArr1(I, 1)
For J = 3 To 5
dArr(K, J) = sArr1(I, J + 1)
Next J
dArr(K, 6) = sArr2(I, 1)
End If
Else
dArr(Dic.Item(Tem), 6) = dArr(Dic.Item(Tem), 6) + sArr2(I, 1)
End If
Next I
With Sheets("GPE_1")
Application.ScreenUpdating = False
.[A4:I10000].ClearContents
.[A4].Resize(K, 9) = dArr
'.[B4].Resize(K, 8).Sort Key1:=.[B4]
Application.ScreenUpdating = True
End With
Set Dic = Nothing
End Sub[/GPECODE]
------------
Đọc bài của HLMT bên dưới mới "mơ hồ" về bài của mình. Híc!

 

[Hai Lúa Miền Tây]

Dùng tạm ADO nhé:

[GPECODE=sql]Sub TongHop()
Dim cn As Object, rst As Object
Dim strSQL As String
Set cn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
.Open
End With
strSQL = "SELECT [BIN Location],[Product Code],[description],[Lot Number], SUM([Qty Picked Whole]) " & _
"FROM [Report$] WHERE LEFT([BIN Location],1)='O' " & _
"GROUP BY [BIN Location],[Product Code],[description],[Lot Number] "
Set rst = cn.Execute(strSQL)
With Sheet3
.[B4:F100].ClearContents
.[B4].CopyFromRecordset rst
End With
rst.Close: cn.Close
Set rst = Nothing: Set cn = Nothing

End Sub

[/GPECODE]

 

[mhieuit]

Thank anh Bate và anh Hai Lúa Miền Tây nhiều, em sẽ test và phản hồi sau nhé

 

[mhieuit]

Code của Hai Lúa Miền Tây run rất OK, còn code cua anh Bate cũng OK nhưng tính tổng chưa được, dù sao em cũng cám ơn 2 anh đã giúp đỡ em rất nhiều, chúc 2 anh ngày làm việc vui vẻ

 

[mhieuit]

Dùng tạm ADO nhé:

[GPECODE=sql]Sub TongHop()
Dim cn As Object, rst As Object
Dim strSQL As String
Set cn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
.Open
End With
strSQL = "SELECT [BIN Location],[Product Code],[description],[Lot Number], SUM([Qty Picked Whole]) " & _
"FROM [Report$] WHERE LEFT([BIN Location],1)='O' " & _
"GROUP BY [BIN Location],[Product Code],[description],[Lot Number] "
Set rst = cn.Execute(strSQL)
With Sheet3
.[B4:F100].ClearContents
.[B4].CopyFromRecordset rst
End With
rst.Close: cn.Close
Set rst = Nothing: Set cn = Nothing

End Sub

[/GPECODE]

Hi anh Hai Lua Mien Tay,
Code của anh chạy rất ok, nhưng phát sinh 1 lỗi như thế này:
- Cột Lot Number (Cột R) sheet Report dạng số thì code chạy ok, link qua sheet BTB.
- Cột Lot Number (Cột R) sheet Report dạng chuỗi (ví dụ:41014811SC) thì khong link qua sheet BTB được.
anh fix giúp em lỗi này nhé,
Cám ơn anh nhiều.

Em gửi thêm file đính kèm, anh giúp em với

 

[Hai Lúa Miền Tây]

Hi anh Hai Lua Mien Tay,
Code của anh chạy rất ok, nhưng phát sinh 1 lỗi như thế này:
- Cột Lot Number (Cột R) sheet Report dạng số thì code chạy ok, link qua sheet BTB.
- Cột Lot Number (Cột R) sheet Report dạng chuỗi (ví dụ:41014811SC) thì khong link qua sheet BTB được.
anh fix giúp em lỗi này nhé,
Cám ơn anh nhiều.

Em gửi thêm file đính kèm, anh giúp em với

Máy tôi chạy bình thường cho dù nó là số hay chuổi, bởi vì tôi đã có khai báo IMEX=1. Thôi thì bạn chỉnh cột R bên sheet Report thành Text hết rồi lưu lại, chạy lại code thử xem thế nào nhé.

 

[nginh]

Thân chào các anh chị GPE,
Em có 1 vấn đề nho nhỏ sau cần sự trợ giúp từ GPE:
- Anh/Chị dùng công thức hoặc code VBA để lọc dữ liệu và tính tổng qua sheet khác.
- Trong file đính kèm Sheet BTB form là kết quả, dữ liệu nguồn là sheet Report.
-Quá trình em làm bằng thủ công để có kết quả sheet BTB form:
+ Sheet Report: Tại cột M em lọc những location bắt đầu là O copy qua sheet BTB form, copy lần lượt dữ liệu tương ứng các cột P, Q, R qua sheet BTB form, sau đó em dùng chức năng Remove Duplicate để lọc bỏ giá trị trùng của Location (cột B sheet BTB form).
+Sheet BTB form: tại cột F em dùng hàm sumif để tính tổng dựa vào điều kiện Location (cột B sheet BTB form) để lấy giá trị bên sheet Report.

Mong Anh/Chị có thể giúp em vấn đề trên.
Em cám ơn!

Bạn thử code sau, run cũng phê lắm

Sub cop()
On Error Resume Next
Dim a(), r As Range, c As Range, f
pref = InputBox("Tim theo ky tu dau :" & Chr(10) & "Vi du : O, OD, D, DS...")
Set f = Sheets("Report").Cells.Find("BIN Location")
Set r = Sheets("Report").Columns(f.Column)
ReDim a(1 To r.Rows.Count, 1 To 5)
Set c = r.Find(pref & "*", f)
If Not c Is Nothing Then
FAdd = c.Address
Do
If WorksheetFunction.Match(c, r, 0) = c.Row - r.Row + 1 Then
i = i + 1
a(i, 1) = c
For j = 2 To 4: a(i, j) = c.Offset(, j + 1): Next
a(i, j) = "=SUMIF(Report!M:M," & """" & a(i, 1) & """" & ",Report!AX:AX)"
End If
Set c = r.FindNext(c)
Loop While Not c Is Nothing And c.Address <> FAdd And c.Address <> f.Address
Sheets("BIN to BIN FORM").Activate
Range([A4], [A4].End(xlDown)).Resize(, 6).ClearContents
[B4].Resize(i, 5) = a
[A4] = 1: [A4].AutoFill [A4].Resize(i), Type:=xlFillSeries
Else: MsgBox "No BIN Location matched"
End If
End Sub

 

[mhieuit]

Máy tôi chạy bình thường cho dù nó là số hay chuổi, bởi vì tôi đã có khai báo IMEX=1. Thôi thì bạn chỉnh cột R bên sheet Report thành Text hết rồi lưu lại, chạy lại code thử xem thế nào nhé.

Em đã làm theo hướng dẫn của anh là chỉnh cột R thành dạng text rồi chay code lại, nhưng kết quả không như mong muốn, máy em xài office 2010, anh check lại giúp em với,
cám ơn anh nhiều.

 

[Hai Lúa Miền Tây]

Em đã làm theo hướng dẫn của anh là chỉnh cột R thành dạng text rồi chay code lại, nhưng kết quả không như mong muốn, máy em xài office 2010, anh check lại giúp em với,
cám ơn anh nhiều.

Máy tôi cũng sd 2010 đây, chạy được mà bạn. Các bạn khác test hộ với.

 

[mhieuit]

Bạn thử code sau, run cũng phê lắm

Sub cop()
On Error Resume Next
Dim a(), r As Range, c As Range, f
pref = InputBox("Tim theo ky tu dau :" & Chr(10) & "Vi du : O, OD, D, DS...")
Set f = Sheets("Report").Cells.Find("BIN Location")
Set r = Sheets("Report").Columns(f.Column)
ReDim a(1 To r.Rows.Count, 1 To 5)
Set c = r.Find(pref & "*", f)
If Not c Is Nothing Then
FAdd = c.Address
Do
If WorksheetFunction.Match(c, r, 0) = c.Row - r.Row + 1 Then
i = i + 1
a(i, 1) = c
For j = 2 To 4: a(i, j) = c.Offset(, j + 1): Next
a(i, j) = "=SUMIF(Report!M:M," & """" & a(i, 1) & """" & ",Report!AX:AX)"
End If
Set c = r.FindNext(c)
Loop While Not c Is Nothing And c.Address <> FAdd And c.Address <> f.Address
Sheets("BIN to BIN FORM").Activate
Range([A4], [A4].End(xlDown)).Resize(, 6).ClearContents
[B4].Resize(i, 5) = a
[A4] = 1: [A4].AutoFill [A4].Resize(i), Type:=xlFillSeries
Else: MsgBox "No BIN Location matched"
End If
End Sub

Cám ơn anh nhiều,
Anh giúp em set code công thức tại cột G4 sheet BTB Form luôn nhé:
=IF(F4="","",IF(F4=0,SUMIF(Report!M:M,BTB_FORM!B4,Report!AY:AY)/VLOOKUP(BTB_FORM!C4,Data!A:F,5,0),""))

 

[mhieuit]

Bạn thử code sau, run cũng phê lắm

Sub cop()
On Error Resume Next
Dim a(), r As Range, c As Range, f
pref = InputBox("Tim theo ky tu dau :" & Chr(10) & "Vi du : O, OD, D, DS...")
Set f = Sheets("Report").Cells.Find("BIN Location")
Set r = Sheets("Report").Columns(f.Column)
ReDim a(1 To r.Rows.Count, 1 To 5)
Set c = r.Find(pref & "*", f)
If Not c Is Nothing Then
FAdd = c.Address
Do
If WorksheetFunction.Match(c, r, 0) = c.Row - r.Row + 1 Then
i = i + 1
a(i, 1) = c
For j = 2 To 4: a(i, j) = c.Offset(, j + 1): Next
a(i, j) = "=SUMIF(Report!M:M," & """" & a(i, 1) & """" & ",Report!AX:AX)"
End If
Set c = r.FindNext(c)
Loop While Not c Is Nothing And c.Address <> FAdd And c.Address <> f.Address
Sheets("BIN to BIN FORM").Activate
Range([A4], [A4].End(xlDown)).Resize(, 6).ClearContents
[B4].Resize(i, 5) = a
[A4] = 1: [A4].AutoFill [A4].Resize(i), Type:=xlFillSeries
Else: MsgBox "No BIN Location matched"
End If
End Sub

Cám ơn anh rất nhiều
em đang test, có gì em sẽ phản hồi sau nhé

 

[nginh]

Cám ơn anh nhiều,
Anh giúp em set code công thức tại cột G4 sheet BTB Form luôn nhé:
=IF(F4="","",IF(F4=0,SUMIF(Report!M:M,BTB_FORM!B4,Report!AY:AY)/VLOOKUP(BTB_FORM!C4,Data!A:F,5,0),""))

Bạn thử lại code sau

Sub cop()
On Error Resume Next
Dim a(), r As Range, c As Range, f
pref = InputBox("Tim theo ky tu dau :" & Chr(10) & "Vi du : O, OD, D, SD...")
Set f = Sheets("Report").Cells.Find("BIN Location")
Set r = Sheets("Report").Columns(f.Column)
ReDim a(1 To r.Rows.Count, 1 To 6)
Set c = r.Find(pref & "*", f)
If Not c Is Nothing Then
FAdd = c.Address
Do
If WorksheetFunction.Match(c, r, 0) = c.Row Then
i = i + 1
a(i, 1) = c
For j = 2 To 4: a(i, j) = c.Offset(, j + 1): Next
a(i, j) = "=SUMIF(Report!M:M," & "B" & (i + 3) & ",Report!AX:AX)"
a(i, j + 1) = "=IF(" & "F" & (i + 3) & "="""","""",IF(" & "F" & (i + 3) & "=0, SUMIF(Report!M:M," _
& "B" & (i + 3) & ",Report!AY:AY)/VLOOKUP(" & "C" & (i + 3) & ",Data!A:F,5,0),""""))"
End If
Set c = r.FindNext(c)
Loop While Not c Is Nothing And c.Address <> FAdd And c.Address <> f.Address
Sheets("BIN to BIN FORM").Activate
Range([A4], [A4].End(xlDown)).Resize(, 7).ClearContents
[B4].Resize(i, 6) = a
[A4] = 1: [A4].AutoFill [A4].Resize(i), Type:=xlFillSeries
Else: MsgBox "No BIN Location matched"
End If
End Sub

Lưu ý đặt tên sheet như trong code

 

[mhieuit]

Bạn thử lại code sau

Sub cop()
On Error Resume Next
Dim a(), r As Range, c As Range, f
pref = InputBox("Tim theo ky tu dau :" & Chr(10) & "Vi du : O, OD, D, SD...")
Set f = Sheets("Report").Cells.Find("BIN Location")
Set r = Sheets("Report").Columns(f.Column)
ReDim a(1 To r.Rows.Count, 1 To 6)
Set c = r.Find(pref & "*", f)
If Not c Is Nothing Then
FAdd = c.Address
Do
If WorksheetFunction.Match(c, r, 0) = c.Row Then
i = i + 1
a(i, 1) = c
For j = 2 To 4: a(i, j) = c.Offset(, j + 1): Next
a(i, j) = "=SUMIF(Report!M:M," & "B" & (i + 3) & ",Report!AX:AX)"
a(i, j + 1) = "=IF(" & "F" & (i + 3) & "="""","""",IF(" & "F" & (i + 3) & "=0, SUMIF(Report!M:M," _
& "B" & (i + 3) & ",Report!AY:AY)/VLOOKUP(" & "C" & (i + 3) & ",Data!A:F,5,0),""""))"
End If
Set c = r.FindNext(c)
Loop While Not c Is Nothing And c.Address <> FAdd And c.Address <> f.Address
Sheets("BIN to BIN FORM").Activate
Range([A4], [A4].End(xlDown)).Resize(, 7).ClearContents
[B4].Resize(i, 6) = a
[A4] = 1: [A4].AutoFill [A4].Resize(i), Type:=xlFillSeries
Else: MsgBox "No BIN Location matched"
End If
End Sub

Lưu ý đặt tên sheet như trong code

Cám ơn anh rất nhiều, Trong đoạn code "=IF(" & "F" & (i + 3) & "="""","""",IF(" & "F" & (i + 3) & "=0, SUMIF(Report!M:M," _
& "B" & (i + 3) & ",Report!AY:AY)/VLOOKUP(" & "C" & (i + 3) & ",Data!A:F,5,0),""""))", chổ "B" & (i + 3) em muốn thay bằng B:B và chổ "C" & (i + 3) thay bằng C:C, anh giúp em nhé

 

[nginh]

Cám ơn anh rất nhiều, Trong đoạn code "=IF(" & "F" & (i + 3) & "="""","""",IF(" & "F" & (i + 3) & "=0, SUMIF(Report!M:M," _
& "B" & (i + 3) & ",Report!AY:AY)/VLOOKUP(" & "C" & (i + 3) & ",Data!A:F,5,0),""""))", chổ "B" & (i + 3) em muốn thay bằng B:B và chổ "C" & (i + 3) thay bằng C:C, anh giúp em nhé

Thi bạn cứ thay "B" & (i + 3) thành "B:B"
và "C" & (i + 3)thành "C:C"

 

[kloud7]

Bạn thử code sau, run cũng phê lắm

Sub cop()
On Error Resume Next
Dim a(), r As Range, c As Range, f
pref = InputBox("Tim theo ky tu dau :" & Chr(10) & "Vi du : O, OD, D, DS...")
Set f = Sheets("Report").Cells.Find("BIN Location")
Set r = Sheets("Report").Columns(f.Column)
ReDim a(1 To r.Rows.Count, 1 To 5)
Set c = r.Find(pref & "*", f)
If Not c Is Nothing Then
FAdd = c.Address
Do
If WorksheetFunction.Match(c, r, 0) = c.Row - r.Row + 1 Then
i = i + 1
a(i, 1) = c
For j = 2 To 4: a(i, j) = c.Offset(, j + 1): Next
a(i, j) = "=SUMIF(Report!M:M," & """" & a(i, 1) & """" & ",Report!AX:AX)"
End If
Set c = r.FindNext(c)
Loop While Not c Is Nothing And c.Address <> FAdd And c.Address <> f.Address
Sheets("BIN to BIN FORM").Activate
Range([A4], [A4].End(xlDown)).Resize(, 6).ClearContents
[B4].Resize(i, 5) = a
[A4] = 1: [A4].AutoFill [A4].Resize(i), Type:=xlFillSeries
Else: MsgBox "No BIN Location matched"
End If
End Sub

Bác Nghinh dạo này chắc ko còn onl trên GPE nữa nên nhờ bác nào chỉnh giúp em code trên về dạng lọc kiểu không điều kiện, sắp xếp đơn thuần theo alphabe trong Sheet Bin to Bin với ah.
Em đang sửa code này để áp dụng nhưng còn đoạn này nữa chưa biết làm thế nào.

Cảm ơn các bác!

 

[kloud7]

Ko bác nào xem giúp em với ah