Find the first occurrence of a cell and if found do the following 4 things......

andymalan

Board Regular
Joined
Feb 22, 2017
Messages
128
Office Version
  1. 365
  2. 2007
Platform
  1. Windows
Greetings all you special people, I am aware that this question may have been answered in some way before, but not entirely to my particular challenge.
I have 2 worksheets in a workbook named "Cabinets" and "Hardware". Thank you so very much, In Advance. I need to do the following....

1. Copy from Sheet “Cabinets” AK2:AL1000 and Paste to Sheets “Hardware” A9 after removing duplicates.

2. Find each occurrence of A9 Sheets “Hardware” in the “Cabinets” Column AK and when found, sum the qty and insert the total into Sheets “Hardware”C9

Find each occurrence of A10 Sheets “Hardware” in the “Cabinets” Column AK and when found, sum the qty and insert the total into Sheets “Hardware”C10

Do this until there is no data in Col A

3. Find the first occurrence of A9 Sheets “Hardware” in the “Cabinets” Column AK and when found, copy qty in Col AM and insert into Sheets “Hardware”D9. (Cost)

4. Multiply D9 with C9 and insert the answer in F9

Multiply D10 with C10 and insert the answer in F10

Multiply D11 with C11 and insert the answer in F11

Do this until there is no data in Col A

This is what I have cobbled together so far,
Application.Goto Reference:="BuyOuts"

ActiveWorkbook.Worksheets("Cabinets").Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Cabinets").Sort.SortFields.Add2 Key:=Range( _

"AK2:AK1000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

xlSortNormal

With ActiveWorkbook.Worksheets("Cabinets").Sort

.SetRange Range("AK1:BB1000")

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Application.Goto Reference:="Code_Item"

Selection.Copy

Sheets("Hardware").Select

Range("A8").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Application.CutCopyMode = False

ActiveSheet.Range("$A$8:$B$1007").RemoveDuplicates Columns:=Array(1, 2), _

Header:=xlYes

Sheets("Cabinets").Select

Range("AK2:AN2").Select

Selection.Copy

Sheets("Hardware").Select

Range("A9").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

End If

End Sub
 

Attachments

  • CabinetsHardware_Page_1.jpg
    CabinetsHardware_Page_1.jpg
    104.6 KB · Views: 10

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Could you post the sample by using XL2BB? so we don't need to retype them.
 
Upvote 0
VBA Code:
Option Explicit
Sub test()
Dim lr&, qty&, cell As Range, arr()
Dim dic As Object
Set dic = CreateObject("Scripting.dictionary")
With Worksheets("Cabinets")
    lr = .Cells(Rows.Count, "AK").End(xlUp).Row
    ReDim arr(1 To lr, 1 To 5)
    For Each cell In .Range("AK2:AK" & lr)
        If Not dic.exists(cell.Value) Then  ' read unique code into dictionary
            qty = cell.Offset(0, 2).Value
            dic.Add cell.Value, qty ' read unique code and quantity into dictionary
            arr(dic.Count, 1) = cell.Offset(0, 1).Value ' read item
            arr(dic.Count, 3) = cell.Offset(0, 3).Value ' read cost
        Else
            qty = qty + cell.Offset(0, 2).Value
            dic(cell.Value) = qty ' read running quantity sum
        End If
    Next
End With
With Worksheets("Hardware")
    .Range("A8").Resize(dic.Count + 1, 6).ClearContents
    .Range("A8:D8").Value = Worksheets("Cabinets").Range("AK1:AN1").Value
    .Range("B9").Resize(dic.Count, 3).Value = arr
    .Range("A9").Resize(dic.Count, 1).Value = WorksheetFunction.Transpose(dic.keys)
    .Range("C9").Resize(dic.Count, 1).Value = WorksheetFunction.Transpose(dic.items)
    .Range("F9").Resize(dic.Count, 1).Formula = "= C9*D9"
    
End With
End Sub
Book1
AKALAMAN
1BO_codeBO_itemBO_qtyBO_cost
2AAAlpha150
3AAAlpha250
4AAAlpha350
5AAAlpha450
6BBBeta590
7CCCelsius670
8DDDelta755
9DDDelta855
10DDDelta955
11DDDelta1055
12EEElephan1160
Cabinets
Cell Formulas
RangeFormula
AM5:AM12AM5=AM4+1

Book1
ABCDEF
8BO_codeBO_itemBO_qtyBO_cost
9AAAlpha1050500
10BBBeta590450
11CCCelsius670420
12DDDelta34551870
13EEElephan1160660
Hardware
Cell Formulas
RangeFormula
F9:F13F9= C9*D9
 
Upvote 0
Dear Bebo 021999, thank you for your input, but something is misfiring.

1652424877847.png

warm regards
Andy
 
Upvote 0

Forum statistics

Threads
1,214,954
Messages
6,122,461
Members
449,085
Latest member
ExcelError

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