View Full Version : extract data from Excel Columns to an Output sheet

07-29-2019, 02:31 AM
I have 2 sheet. One is the Source- This contains 1) ID no.s in Column B starting from Cell B3. 2) Colour in Column C and 3) The Amounts I have to retrieve are in Column E.
Then in the Output Sheet, I must paste the ID no. in column A. (in an un-used row), next paste the Amount in the same row. Row 1 in Output sheet contains all the Colours. So the macro would have to find the corresponding colour from source and match it to the one in Output and paste in the correct matching cell.

Column B which contains the Id's some contains blanks because it has multiple colours.

Source sheet would look like this

name ID Colour Amount Status
asda A1 Red 12
cccc 1B Red 76
ddd 2C Red 56
Blue 78
Green 532
Yellow 43
qqq 34V Yellow 566

Outputsheet would look like this...

Red Blue Green Yellow
1A 12
1B 76
2C 56 78 532 43
34V 566

07-29-2019, 04:15 AM
Public Sub ExtractData()
Dim wsRes As Worksheet
Dim nextrow As Long
Dim lastrow As Long
Dim i As Long

On Error Resume Next
Application.DisplayAlerts = False
Application.DisplayAlerts = True
On Error GoTo 0

With ActiveSheet

Set wsRes = Worksheets.Add(after:=Worksheets(Worksheets.Count))
wsRes.Name = "Output"
wsRes.Range("A1:E1").Value = Array("Id", "Red", "Blue", "Green", "Yellow")

nextrow = 1
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = 2 To lastrow

If Not .Cells(i, "B").Value = vbNullString Then

nextrow = nextrow + 1
.Cells(i, "B").Copy wsRes.Cells(nextrow, "A")
End If
.Cells(i, "E").Copy wsRes.Cells(nextrow, wsRes.Cells(nextrow, wsRes.Columns.Count).End(xlToLeft).Column + 1)
Next i
End With
End Sub

07-29-2019, 06:32 PM
The Output sheet already exists. I cant see where it is pasting in the Output sheet? I require it to find the ID and paste in column A if it doesnt already exist, then add the amount under the correct colour. There will be more than 20 colours so dont want to add them to an array simply find a match. Something like this.

Set rngFoundCells = wOutput.Rows(1).Find(What:=CStr(strColour), LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)