Construct a report from 2 sheets have individual parts

[PRADEEPB270]

I have stucked in a working and want to solution from VBA codes.

I have a file have 2 sheets.One is 'Current' and other is 'Previous'.Want to automate create a 'Summary' sheet who reveals the individual parts in both the sheets also other datas.Means,if any part is appearing in both sheets,which is common,that should not be include in summary sheet.I have tried my best to explain the same in column K in my attach sheet.

Can it be posible through Macro ?

[HansV]

Should we look at the Part Code column?

[PRADEEPB270]

Yes sir.Look up the part code first and according to its rest of datas.

[HansV]

Here is a first version:

Code: Select all

Sub CreateList()
    ' First data row
    Const FirstRow = 6
    Dim wshC As Worksheet
    Dim wshP As Worksheet
    Dim wshS As Worksheet
    Dim rngC As Range
    Dim celC As Range
    Dim rngP As Range
    Dim celP As Range
    Dim LastRow As Long
    Dim lngRow As Long
    Application.ScreenUpdating = False
    lngRow = FirstRow
    ' Set references to worksheets
    Set wshC = Worksheets("Current")
    Set wshP = Worksheets("Previous")
    Set wshS = Worksheets("Summary")
    ' Clear existing data from Summary sheet
    wshS.Range("A" & FirstRow & ":K" & wshS.Rows.Count).ClearContents
    ' Used range in column B on Current sheet
    LastRow = wshC.Range("B" & wshC.Rows.Count).End(xlUp).Row
    Set rngC = wshC.Range("B" & FirstRow & ":B" & LastRow)
    ' Used range in column B on Previous sheet
    LastRow = wshP.Range("B" & wshP.Rows.Count).End(xlUp).Row
    Set rngP = wshP.Range("B" & FirstRow & ":B" & LastRow)
    ' Loop through rows on Current sheet
    For Each celC In rngC
        If celC.Value <> "" Then
            ' Try to find value on Previous sheet
            Set celP = rngP.Find(What:=celC.Value, LookAt:=xlWhole)
            If celP Is Nothing Then
                lngRow = lngRow + 1
                wshS.Range("B" & lngRow & ":E" & lngRow).Value = _
                    celC.Resize(ColumnSize:=4).Value
                wshS.Range("G" & lngRow).Value = celC.Offset(ColumnOffset:=4).Value
                wshS.Range("I" & lngRow).Value = celC.Offset(ColumnOffset:=5).Value
                wshS.Range("K" & lngRow).Value = "Does not appear in Previous sheet"
            End If
        End If
    Next celC
    ' Loop through rows on Previous sheet
    For Each celP In rngP
        If celP.Value <> "" Then
            ' Try to find value on Current sheet
            Set celC = rngC.Find(What:=celP.Value, LookAt:=xlWhole)
            If celC Is Nothing Then
                lngRow = lngRow + 1
                wshS.Range("B" & lngRow & ":D" & lngRow).Value = _
                    celP.Resize(ColumnSize:=3).Value
                wshS.Range("F" & lngRow).Value = celP.Offset(ColumnOffset:=3).Value
                wshS.Range("H" & lngRow).Value = celP.Offset(ColumnOffset:=4).Value
                wshS.Range("J" & lngRow).Value = celP.Offset(ColumnOffset:=5).Value
                wshS.Range("K" & lngRow).Value = "Does not appear in Current sheet"
            End If
        End If
    Next celP
    Application.ScreenUpdating = True
End Sub

[PRADEEPB270]

Macro is working perfect but only one problem.The problem is one part code should not repeat twice or more.It should be only appear as once and sum up the Qty and amount of these type of parts.

Please refer my attach file as 'revised parts'.In this file,the result of row no.13 to 16 should be as row no.28 and 29.


Rate formula=Amount/Qty

[HansV]

Code: Select all

Sub CreateList()
    ' First data row
    Const FirstRow = 6
    Dim wshC As Worksheet
    Dim wshP As Worksheet
    Dim wshS As Worksheet
    Dim rngC As Range
    Dim celC As Range
    Dim rngP As Range
    Dim celP As Range
    Dim celS As Range
    Dim LastRow As Long
    Dim lngRow As Long
    Application.ScreenUpdating = False
    lngRow = FirstRow
    ' Set references to worksheets
    Set wshC = Worksheets("Current")
    Set wshP = Worksheets("Previous")
    Set wshS = Worksheets("Summary")
    ' Clear existing data from Summary sheet
    wshS.Range("A" & FirstRow & ":K" & wshS.Rows.Count).ClearContents
    ' Used range in column B on Current sheet
    LastRow = wshC.Range("B" & wshC.Rows.Count).End(xlUp).Row
    Set rngC = wshC.Range("B" & FirstRow & ":B" & LastRow)
    ' Used range in column B on Previous sheet
    LastRow = wshP.Range("B" & wshP.Rows.Count).End(xlUp).Row
    Set rngP = wshP.Range("B" & FirstRow & ":B" & LastRow)
    ' Loop through rows on Current sheet
    For Each celC In rngC
        If celC.Value <> "" Then
            ' Try to find value on Previous sheet
            Set celP = rngP.Find(What:=celC.Value, LookAt:=xlWhole)
            If celP Is Nothing Then
                Set celS = wshS.Range("B:B").Find(What:=celC.Value, LookAt:=xlWhole)
                If celS Is Nothing Then
                    lngRow = lngRow + 1
                    wshS.Range("B" & lngRow & ":E" & lngRow).Value = _
                        celC.Resize(ColumnSize:=4).Value
                    wshS.Range("G" & lngRow).Value = celC.Offset(ColumnOffset:=4).Value
                    wshS.Range("I" & lngRow).Value = celC.Offset(ColumnOffset:=5).Value
                    wshS.Range("K" & lngRow).Value = "Does not appear in Previous sheet"
                Else
                    celS.Offset(ColumnOffset:=3).Value = celS.Offset(ColumnOffset:=3).Value + _
                        celC.Offset(ColumnOffset:=3).Value
                    celS.Offset(ColumnOffset:=5).Value = celS.Offset(ColumnOffset:=5).Value + _
                        celC.Offset(ColumnOffset:=4).Value
                    celS.Offset(ColumnOffset:=7).Value = celS.Offset(ColumnOffset:=7).Value + _
                        celC.Offset(ColumnOffset:=5).Value
                End If
            End If
        End If
    Next celC
    ' Loop through rows on Previous sheet
    For Each celP In rngP
        If celP.Value <> "" Then
            ' Try to find value on Current sheet
            Set celC = rngC.Find(What:=celP.Value, LookAt:=xlWhole)
            If celC Is Nothing Then
                Set celS = wshS.Range("B:B").Find(What:=celP.Value, LookAt:=xlWhole)
                If celS Is Nothing Then
                    lngRow = lngRow + 1
                    wshS.Range("B" & lngRow & ":D" & lngRow).Value = _
                        celP.Resize(ColumnSize:=3).Value
                    wshS.Range("F" & lngRow).Value = celP.Offset(ColumnOffset:=3).Value
                    wshS.Range("H" & lngRow).Value = celP.Offset(ColumnOffset:=4).Value
                    wshS.Range("J" & lngRow).Value = celP.Offset(ColumnOffset:=5).Value
                    wshS.Range("K" & lngRow).Value = "Does not appear in Current sheet"
                Else
                    celS.Offset(ColumnOffset:=4).Value = celS.Offset(ColumnOffset:=4).Value + _
                        celP.Offset(ColumnOffset:=3).Value
                    celP.Offset(ColumnOffset:=6).Value = celS.Offset(ColumnOffset:=6).Value + _
                        celC.Offset(ColumnOffset:=4).Value
                    celP.Offset(ColumnOffset:=8).Value = celS.Offset(ColumnOffset:=8).Value + _
                        celC.Offset(ColumnOffset:=5).Value
                End If
            End If
        End If
    Next celP
    Application.ScreenUpdating = True
End Sub

[PRADEEPB270]

Only the rate calculation formula has disturbed.It should be 'Amount'/'Qty'.The formulas on all the rows are ok except the rows 13 and 14.It should be as rows 26 and 27 and cell no.G26 and 27.

Please refer my attach file .

[HansV]

It helps if you explain the conditions beforehand instead of bit by bit after each reply.

Code: Select all

Sub CreateList()
    ' First data row
    Const FirstRow = 6
    Dim wshC As Worksheet
    Dim wshP As Worksheet
    Dim wshS As Worksheet
    Dim rngC As Range
    Dim celC As Range
    Dim rngP As Range
    Dim celP As Range
    Dim celS As Range
    Dim LastRow As Long
    Dim lngRow As Long
    Application.ScreenUpdating = False
    lngRow = FirstRow
    ' Set references to worksheets
    Set wshC = Worksheets("Current")
    Set wshP = Worksheets("Previous")
    Set wshS = Worksheets("Summary")
    ' Clear existing data from Summary sheet
    wshS.Range("A" & FirstRow & ":K" & wshS.Rows.Count).ClearContents
    ' Used range in column B on Current sheet
    LastRow = wshC.Range("B" & wshC.Rows.Count).End(xlUp).Row
    Set rngC = wshC.Range("B" & FirstRow & ":B" & LastRow)
    ' Used range in column B on Previous sheet
    LastRow = wshP.Range("B" & wshP.Rows.Count).End(xlUp).Row
    Set rngP = wshP.Range("B" & FirstRow & ":B" & LastRow)
    ' Loop through rows on Current sheet
    For Each celC In rngC
        If celC.Value <> "" Then
            ' Try to find value on Previous sheet
            Set celP = rngP.Find(What:=celC.Value, LookAt:=xlWhole)
            If celP Is Nothing Then
                Set celS = wshS.Range("B:B").Find(What:=celC.Value, LookAt:=xlWhole)
                If celS Is Nothing Then
                    lngRow = lngRow + 1
                    wshS.Range("B" & lngRow & ":E" & lngRow).Value = _
                        celC.Resize(ColumnSize:=4).Value
                    wshS.Range("I" & lngRow).Value = celC.Offset(ColumnOffset:=5).Value
                    wshS.Range("G" & lngRow).Value = wshS.Range("I" & lngRow).Value / _
                        wshS.Range("E" & lngRow).Value
                    wshS.Range("K" & lngRow).Value = "Does not appear in Previous sheet"
                Else
                    celS.Offset(ColumnOffset:=3).Value = celS.Offset(ColumnOffset:=3).Value + _
                        celC.Offset(ColumnOffset:=3).Value
                    celS.Offset(ColumnOffset:=7).Value = celS.Offset(ColumnOffset:=7).Value + _
                        celC.Offset(ColumnOffset:=5).Value
                    celS.Offset(ColumnOffset:=5).Value = celS.Offset(ColumnOffset:=7).Value / _
                        celS.Offset(ColumnOffset:=3).Value
                End If
            End If
        End If
    Next celC
    ' Loop through rows on Previous sheet
    For Each celP In rngP
        If celP.Value <> "" Then
            ' Try to find value on Current sheet
            Set celC = rngC.Find(What:=celP.Value, LookAt:=xlWhole)
            If celC Is Nothing Then
                Set celS = wshS.Range("B:B").Find(What:=celP.Value, LookAt:=xlWhole)
                If celS Is Nothing Then
                    lngRow = lngRow + 1
                    wshS.Range("B" & lngRow & ":D" & lngRow).Value = _
                        celP.Resize(ColumnSize:=3).Value
                    wshS.Range("F" & lngRow).Value = celP.Offset(ColumnOffset:=3).Value
                    wshS.Range("J" & lngRow).Value = celP.Offset(ColumnOffset:=5).Value
                    wshS.Range("H" & lngRow).Value = wshS.Range("J" & lngRow).Value / _
                        wshS.Range("F" & lngRow).Value
                    wshS.Range("K" & lngRow).Value = "Does not appear in Current sheet"
                Else
                    celS.Offset(ColumnOffset:=4).Value = celS.Offset(ColumnOffset:=4).Value + _
                        celP.Offset(ColumnOffset:=3).Value
                    celS.Offset(ColumnOffset:=8).Value = celS.Offset(ColumnOffset:=8).Value + _
                        celP.Offset(ColumnOffset:=5).Value
                    celS.Offset(ColumnOffset:=6).Value = celS.Offset(ColumnOffset:=8).Value / _
                        celS.Offset(ColumnOffset:=4).Value
                End If
            End If
        End If
    Next celP
    Application.ScreenUpdating = True
End Sub

[PRADEEPB270]

Sorry for my earlier mistakes.

Now,the perfect macro is in my hand and working so well as I desired.Very glad to find the same.

Thanks a lot Hans for all credit.