PDA

View Full Version : [SOLVED] Post filter using loops



sahilkh
06-15-2017, 12:39 PM
Hello

I have a sheet from which I need to import data into another file using vba.

The condition is that it needs to pick up information only if there is a specific quantity listed under it.

I'm attaching the source file and the output file. Please advise the best possible way to accomplish this task.

Thank you

Sahil

Leith Ross
06-15-2017, 01:27 PM
Hello sahilkh,

The two files you posted are the identical.

sahilkh
06-15-2017, 01:38 PM
Sorry about that. Attached the source file now

sahilkh
06-15-2017, 01:40 PM
Hello Leith

In simple terms, I just need to filter and paste the data for each order number from the source sheet along with the quantity in the output sheet.

Leith Ross
06-15-2017, 01:55 PM
Hello Sahilkh,

That helps but I don't see any headers on the Delivery sheet marked "Amount" or "Unit".

sahilkh
06-15-2017, 02:56 PM
This data will be changing every day.

I already have the codes for those two headers ready.

My main challenge is to get the appropriate data for each individual order number and put in the format (output sheet).

There is a loop which will be run for the Unit and the amount column is to remain blank as of now.

Thanks

Leith Ross
06-15-2017, 10:10 PM
Hello Sahilka,

The macro in the attached workbook should provide us with a good starting point. It requires the other workbook "Output File.xlsx" to already be open.

Try it out and let me know your thoughts on the results. Run the macro using the Macro Dialog, ALT+F8 in Excel, or from the VB Editor.



Sub OutputOrderData()

Dim Cell As Range
Dim Data As Variant
Dim DescRng As Range
Dim Dict As Object
Dim Item As Variant
Dim Label As Range
Dim Order As Variant
Dim RngBeg As Range
Dim RngEnd As Range
Dim row As Long
Dim Wkb As Workbook
Dim WkbName As String
Dim Wks As Worksheet

' Name of the Output workbook already open.
WkbName = "Output File.xlsx"

' Name of the source worksheet in this workbook.
Set Wks = ThisWorkbook.Worksheets("Sheet1")

Set RngBeg = Wks.Range("A2")
Set RngEnd = Wks.Cells(Rows.Count, "A").End(xlUp)
If RngEnd.row < RngBeg.row Then Exit Sub

' These columns in row 1 are the product descriptions.
Set DescRng = Wks.Range("G1:W1")

Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare

For Each Cell In Wks.Range(RngBeg, RngEnd)
Order = Trim(Cell)
If Order <> "" Then
If Not Dict.Exists(Order) Then
' Find the first non empty column for the product.
Set Label = DescRng.Offset(Cell.row - DescRng.row + 1, 0).Find("*", , xlValues, xlWhole, xlByColumns, xlNext, False, False, False)
' Save the product data if quantity is not zero.
If Not Label Is Nothing Then
ReDim Data(1 To 1, 1 To 3)
Data(1, 1) = Order
Data(1, 2) = DescRng.Cells(1, Label.Column - 6).Value
Data(1, 3) = Cell.Offset(0, Label.Column - 1).Value
Dict.Add Order, Data
End If
End If
End If
Next Cell

' Check the output workbook is open.
On Error Resume Next
Set Wkb = Workbooks(WkbName)
If Err <> 0 Then
If Err = 9 Then
MsgBox "The Workbook """ & WkbName & """ is Not Open." & vbLf _
& "Please open the workbook and run this macro again."
Else
MsgBox "Run-time error '" & Err.Number & "':" & vbCrLf & vbCrLf & Err.Description
End If
Exit Sub
End If
On Error GoTo 0

Application.ScreenUpdating = False

' Output the product data and the sort it in ascending order by order number.
With Wkb.Worksheets(1)
Intersect(.UsedRange, .UsedRange.Offset(1, 0)).ClearContents
Set Cell = .Range("A2:C2")
row = 0
For Each Item In Dict.Items
Cell.Offset(row, 0).Value = Item
row = row + 1
Next Item
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.UsedRange.Columns(1), Order:=xlAscending, SortOn:=xlSortOnValues
.Sort.Header = xlYes
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SetRange .UsedRange
.Sort.Apply
End With

Application.ScreenUpdating = True

End Sub

sahilkh
06-16-2017, 05:41 AM
Thank you for the code Leith.

While it seems to be doing most of the work, it is not doing exactly what i needed. I am also unable to modify it to get the desired results, so need some more help from you.

Let me try and explain what I need:

Order 1 has 1 box of Cherries and 1 box of Whole Wheat Atta. There would be 1 mentioned in front of the order number under the respective columns.

I want the code to print each of these values per order separately in the output sheet.

The input file would look like:

Order Cherries Atta (there can be blank columns between these two columns, as you saw in the earlier files attached)
001 1 1

Output file:
Order Product Quantity
001 Cherries 1
001 Atta 1

If you need me to modify the excel file as well, please let me know and I can send you the draft there.

I have an existing code I am running to create the final output file. So we can do away with part of the code, which is checking if the output file is open or not.

I will attach my file with the code as well so that you know what I am talking about.

Appreciate your help immensely.

Hope this helps,

Leith Ross
06-16-2017, 12:04 PM
Hello Sahilkh,

Here is the revised macro. It will now handle multiple products for a single order. Try it and let me know if anything needs to changed.



Sub OutputOrderData()

Dim Cell As Range
Dim Data As Variant
Dim DescRng As Range
Dim Dict As Object
Dim Items As Variant
Dim j As Long
Dim k As Long
Dim Label As Range
Dim n As Long
Dim Order As Variant
Dim RngBeg As Range
Dim RngEnd As Range
Dim row As Long
Dim Qty As Variant
Dim Wkb As Workbook
Dim WkbName As String
Dim Wks As Worksheet

' Name of the Output workbook already open.
WkbName = "Output File.xlsx"

' Name of the source worksheet in this workbook.
Set Wks = ThisWorkbook.Worksheets("Sheet1")

Set RngBeg = Wks.Range("A2")
Set RngEnd = Wks.Cells(Rows.Count, "A").End(xlUp).Offset(-1, 0) ' Do not include the Grand Total row.
If RngEnd.row < RngBeg.row Then Exit Sub

' These columns in row 1 are the product descriptions.
Set DescRng = Wks.Range("G1:W1")

Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare

For Each Cell In Wks.Range(RngBeg, RngEnd)
Order = Trim(Cell)
If Order <> "" Then
If Not Dict.Exists(Order) Then
Qty = DescRng.Offset(Cell.row - 1, 0).Value

' Return an array of the product quantities.
n = 0
For Each Item In Qty
If Item > 0 Then n = n + 1
Next Item

' Save the order number, product description, and quantity if the order quntities are not zero.
If n > 0 Then
j = 0
ReDim Data(1 To n, 1 To 3)
For k = 1 To DescRng.Columns.Count
If Qty(1, k) > 0 Then
j = j + 1
Data(j, 1) = Order
Data(j, 2) = DescRng.Cells(1, k).Value
Data(j, 3) = Qty(1, k)
End If
Next k
Dict.Add Order, Data
End If
End If
End If
Next Cell

' Check the output workbook is open.
On Error Resume Next
Set Wkb = Workbooks(WkbName)
If Err <> 0 Then
If Err = 9 Then
MsgBox "The Workbook """ & WkbName & """ is Not Open." & vbLf _
& "Please open the workbook and run this macro again."
Else
MsgBox "Run-time error '" & Err.Number & "':" & vbCrLf & vbCrLf & Err.Description
End If
Exit Sub
End If
On Error GoTo 0

Application.ScreenUpdating = False

' Output the product data and the sort it in ascending order by order number.
With Wkb.Worksheets(1)
row = 0
Set Cell = .Range("A2:C2")
Intersect(.UsedRange, .UsedRange.Offset(1, 0)).ClearContents

For Each Order In Dict.Items
Cell.Offset(row, 0).Resize(RowSize:=UBound(Order, 1)).Value = Order
row = row + UBound(Order, 1)
Next Order

.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.UsedRange.Columns(1), Order:=xlAscending, SortOn:=xlSortOnValues
.Sort.Header = xlYes
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SetRange .UsedRange
.Sort.Apply
End With

Application.ScreenUpdating = True

End Sub