Making a summer sheet from packing list in VBA

mehidy1437

mehidy1437

Active Member
Joined
Nov 15, 2019
Messages
348
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Hi Guys,

I have a packing list with details.
I need to make a summer sheet with ,
Column A ->contain the style no.
Column B ->contain the order no.
Column C->contain the ref no.
Column G ->contain the Color no.
Column H:S ->contain the sizes. Here sizes are 4 - XXL, but some time sizes can be 6-3XL also
Column T ->contain the number of carton.

Note:
01.Column H:S cell values, will multiple with the T column cell value to get the sizes wise total qty.
02.Row/Range can be vary time to time for different style.

Here below the summer sheet snap.
XL file in Google Drive

1575354791187.png


How can i do this in VBA, kindly help?
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Sort by date Sort by votes
Sorry guys,
There was some mistake in the first file, here below the correction file.
Updated XL file

Summery Sheet:
1575365114064.png
 
Upvote 0
Okay guys, I have come up with the solution as below.
If anyone has any comments or suggestion, plz let me know.

VBA Code: 
Option Explicit

Sub SummeryPAKL()
Application.ScreenUpdating = False
Dim ActvSheetNumb As Integer
Dim AddedSheetNumb As Integer
ActvSheetNumb = ActiveSheet.Index
AddedSheetNumb = ActvSheetNumb + 1

Dim StyleAreaSt As Range
Dim StyleIdStrt  As String
Dim StyleStarts  As String
Dim StyleStartsRowNum As Integer
Set StyleAreaSt = Range("A:A").Find(What:=("Style"), LookIn:=xlValues, lookat:=xlWhole)
StyleIdStrt = StyleAreaSt.Address(0, 0)
StyleStarts = StyleAreaSt.Offset(2, 0).Address(0, 0)
StyleStartsRowNum = Range(StyleAreaSt.Offset(2, 0).Address).row
    
    Dim StyleAreaEnd As Range
    Dim StyleIdEnd  As String
    Dim StyleEnd  As String
    Dim StyleEndRowNum As Integer
    Set StyleAreaEnd = Range("A:A").Find(What:=("Total="), LookIn:=xlValues, lookat:=xlWhole)
    StyleIdEnd = StyleAreaEnd.Address(0, 0)
    StyleEnd = StyleAreaEnd.Offset(-1, 0).Address(0, 0)
    StyleEndRowNum = Range(StyleAreaEnd.Offset(-1, 0).Address).row
    
    'Range("Ad10:Ad57") = Range(StyleStarts & ":" & StyleEnd).Value
    'Add = Range(StyleStarts & ":" & StyleEnd)
            Dim h1 As Worksheet
            Set h1 = ActiveSheet
            Dim h2 As Worksheet
            Set h2 = ActiveWorkbook.Sheets.Add(Type:=xlWorksheet, After:=Application.ActiveSheet)
            
            Dim row As Long
            Dim col As Long
            Dim x As Long
        
            ActiveSheet.Select
            x = 2
            
            'Headers Sheet2
            Sheets(AddedSheetNumb).Cells(1, 1).Value = "Style"
            Sheets(AddedSheetNumb).Cells(1, 2).Value = "Order Id"
            Sheets(AddedSheetNumb).Cells(1, 3).Value = "Ref"
            Sheets(AddedSheetNumb).Cells(1, 4).Value = "Color"
            Sheets(AddedSheetNumb).Cells(1, 5).Value = "Size"
            Sheets(AddedSheetNumb).Cells(1, 6).Value = "Qty"
            Sheets(AddedSheetNumb).Cells(1, 7).Value = "Ctn Qty"
            Sheets(AddedSheetNumb).Cells(1, 8).Value = "Total Qty"
                        
            For row = StyleStartsRowNum To StyleEndRowNum
            'For row = StyleStartsRowNum To Range(StyleStarts & ":" & StyleEnd).Rows.Count
                'For col = 8 To Range(StyleStarts & ":" & StyleEnd).Columns.Count
                For col = 8 To 19 ' sizes column
                    Sheets(AddedSheetNumb).Cells(x, 1).Value = Sheets(ActvSheetNumb).Cells(row, 1).Value 'style
                    Sheets(AddedSheetNumb).Cells(x, 2).Value = Sheets(ActvSheetNumb).Cells(row, 2).Value 'order no
                    Sheets(AddedSheetNumb).Cells(x, 3).Value = Sheets(ActvSheetNumb).Cells(row, 3).Value ' ref no
                    Sheets(AddedSheetNumb).Cells(x, 4).Value = Sheets(ActvSheetNumb).Cells(row, 7).Value 'color
                    Sheets(AddedSheetNumb).Cells(x, 5).Value = Sheets(ActvSheetNumb).Cells(9, col).Value 'sizes from pkl sheet
                    Sheets(AddedSheetNumb).Cells(x, 6).Value = Sheets(ActvSheetNumb).Cells(row, col).Value 'size wise qty
                    Sheets(AddedSheetNumb).Cells(x, 7).Value = Sheets(ActvSheetNumb).Cells(row, 20).Value 'ctn qty
                    Sheets(AddedSheetNumb).Cells(x, 8).Value = Sheets(AddedSheetNumb).Cells(x, 6).Value * Sheets(AddedSheetNumb).Cells(x, 7).Value
             x = x + 1
                Next
            Next
            
Sheets(AddedSheetNumb).Columns("F:F").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True

End Sub
 
Upvote 0
Here is the final solutions:

VBA Code: 
Option Explicit

Sub SummeryPAKL()

Application.ScreenUpdating = False

Dim ActvSheetNumb As Integer
Dim AddedSheetNumb As Integer
ActvSheetNumb = ActiveSheet.Index
AddedSheetNumb = ActvSheetNumb + 1

Dim StyleAreaSt As Range
Dim StyleIdStrt  As String
Dim StyleStarts  As String
Dim StyleStartsRowNum As Integer
Set StyleAreaSt = Range("A:A").Find(What:=("Style"), LookIn:=xlValues, lookat:=xlWhole)
StyleIdStrt = StyleAreaSt.Address(0, 0)
StyleStarts = StyleAreaSt.Offset(2, 0).Address(0, 0)
StyleStartsRowNum = Range(StyleAreaSt.Offset(2, 0).Address).row
    
    Dim StyleAreaEnd As Range
    Dim StyleIdEnd  As String
    Dim StyleEnd  As String
    Dim StyleEndRowNum As Integer
    Set StyleAreaEnd = Range("A:A").Find(What:=("Total="), LookIn:=xlValues, lookat:=xlWhole)
    StyleIdEnd = StyleAreaEnd.Address(0, 0)
    StyleEnd = StyleAreaEnd.Offset(-1, 0).Address(0, 0)
    StyleEndRowNum = Range(StyleAreaEnd.Offset(-1, 0).Address).row
    
            Dim h1 As Worksheet
            Set h1 = ActiveSheet
            Dim h2 As Worksheet
            Set h2 = ActiveWorkbook.Sheets.Add(Type:=xlWorksheet, After:=Application.ActiveSheet)
            
            Dim row As Long
            Dim col As Long
            Dim x As Long
        
            ActiveSheet.Select
            x = 2
            
            'Headers Sheet2
            Sheets(AddedSheetNumb).Cells(1, 1).Value = "Style"
            Sheets(AddedSheetNumb).Cells(1, 2).Value = "Order Id"
            Sheets(AddedSheetNumb).Cells(1, 3).Value = "Ref"
            Sheets(AddedSheetNumb).Cells(1, 4).Value = "Color"
            Sheets(AddedSheetNumb).Cells(1, 5).Value = "Size"
            Sheets(AddedSheetNumb).Cells(1, 6).Value = "Qty"
            Sheets(AddedSheetNumb).Cells(1, 7).Value = "Ctn Qty"
            Sheets(AddedSheetNumb).Cells(1, 8).Value = "Total Qty"
            
               For row = StyleStartsRowNum To StyleEndRowNum
                   For col = 8 To 19 ' sizes column
                    Sheets(AddedSheetNumb).Cells(x, 1).Value = Sheets(ActvSheetNumb).Cells(row, 1).Value 'style
                    Sheets(AddedSheetNumb).Cells(x, 2).Value = Sheets(ActvSheetNumb).Cells(row, 2).Value 'order no
                    Sheets(AddedSheetNumb).Cells(x, 3).Value = Sheets(ActvSheetNumb).Cells(row, 3).Value ' ref no
                    Sheets(AddedSheetNumb).Cells(x, 4).Value = Sheets(ActvSheetNumb).Cells(row, 7).Value 'color
                    Sheets(AddedSheetNumb).Cells(x, 5).Value = Sheets(ActvSheetNumb).Cells(9, col).Value 'sizes from pkl sheet
                    Sheets(AddedSheetNumb).Cells(x, 6).Value = Sheets(ActvSheetNumb).Cells(row, col).Value 'size wise qty
                    Sheets(AddedSheetNumb).Cells(x, 7).Value = Sheets(ActvSheetNumb).Cells(row, 20).Value 'ctn qty
                    Sheets(AddedSheetNumb).Cells(x, 8).Value = Sheets(AddedSheetNumb).Cells(x, 6).Value * Sheets(AddedSheetNumb).Cells(x, 7).Value
                    x = x + 1
                Next
            Next
            
Sheets(AddedSheetNumb).Columns("F:F").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'2nd part finding duplicate value a-e
Dim lr As Long, i As Long
lr = Cells(Rows.Count, 1).End(xlUp).row

    With Sheets(AddedSheetNumb).Sort
        .Header = xlYes
        .SortFields.Clear
        .SetRange Range(Cells(1, 1), Cells(lr, 8))
        '.SetRange Range(Cells(1, 1), Cells(DataRows, 8))
        .SortFields.Add Key:=Range("B:B"), Order:=xlAscending
        .SortFields.Add Key:=Range("C:C"), Order:=xlAscending
        .SortFields.Add Key:=Range("D:D"), Order:=xlAscending
        .SortFields.Add Key:=Range("E:E"), Order:=xlAscending
        .Apply
        .SortFields.Clear
    End With

For i = lr To 2 Step -1
    If Cells(i, 1) = Cells(i - 1, 1) And _
    Cells(i, 2) = Cells(i - 1, 2) And _
    Cells(i, 3) = Cells(i - 1, 3) And _
    Cells(i, 4) = Cells(i - 1, 4) And _
    Cells(i, 5) = Cells(i - 1, 5) Then
        Cells(i - 1, 6) = Cells(i - 1, 6) + Cells(i, 6)
        Cells(i - 1, 7) = Cells(i - 1, 7) + Cells(i, 7)
        Cells(i - 1, 8) = Cells(i - 1, 8) + Cells(i, 8)
        Range("A" & i & ":h" & i).Delete shift:=xlUp
    End If
Next i

Application.ScreenUpdating = True

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Excel VBA to create multi rows based on column header
Replies
1
Views
282
bebo021999
B
A
  • Question
Dynamically add new rows via VBA when using IFERROR TEXTJOIN and FILTER formulas from Table?
Replies
0
Views
80
AlfredDB
A
I
  • Question
Move multiple rows from one table to another using conditional trigger
Replies
2
Views
468
ItsNursinTime
I
C
  • Question
Compare cells in rows from 2 differents sheets before copy
2
Replies
15
Views
335
Tupe77
T
B
  • Question
VBA Extract data from one Workbook and Transpose Paste to another
Replies
5
Views
902
DanteAmor
DanteAmor

Forum statistics

Threads
1,214,986
Messages
6,122,611
Members
449,090
Latest member
vivek chauhan

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top