Vba code to find columns with any data move over to copy data then insert row below and paste both items

KathCobb · Apr 29th 2020

Ok, with a lot of help I have been able to create several excel vba modules and they have been unbelievable helpful, but I do not know where to begin with this one.

I have Column D that has a master number. In column E is misc info, Column F is the Main field that I need (product in this case) . In Column G thru AK are acceptable product names that match the master number. So what I need is to figure if there is a way to write a code that says:

For every number in column D, Check column G through AK for text. For text found in each column, I'll need to copy that master number, insert a row, put that master number in column D of new row and move the text from the original column G through AK to Column F in new row.

So my excel sheet looks like this:

Column D Column E Column F Column G Column H Column I Column J Etc

12345 XXXXXXX Soap Soap Bar Soap Crystal Soap Liquid Soap Foam

12222 XXXXXXX Soda Soda Can Soda Bottle blank blank

And I need it to become this:

Column D Column E Column F Column G Column H Column I Column J Etc

12345 XXXXXXX Soap

12345 XXXXXXX Soap Bar

12345 XXXXXXX Soap Crystal

12345 XXXXXXX Soap Liquid

12345 XXXXXXX Soap Foam

12222 XXXXXXX Soda

12222 XXXXXXX Soda Can

12222 XXXXXXX Soda Bottle

Is there a way to do this in code? I know how to search for specific data and copy it and move it with Select Case but asking it to look thru 31 columns ignore if they re blank and then copy the text in that column and another specific column is way out of my league. I have zero experience with loops.

Any and all code assistance would be greatly appreciated.

Kathy

dangelor · Apr 30th 2020

Possibly...

Code

Sub Find_and_Move_Data()
Dim C As Collection
Dim rg As Range
Dim i As Long, j As Long
Dim k As Long, lRow As Long
'Assumes data begins in A1
With ThisWorkbook
Set rg = .Worksheets("Sheet1").Cells(1, 4).CurrentRegion
.Worksheets.Add Before:=.Worksheets(1)
With Worksheets(1)
rg.Rows(1).Copy .Cells(1, 1)
For i = 2 To rg.Rows.Count
Set C = New Collection
For j = 1 To rg.Columns.Count
If Not IsEmpty(rg(i, j)) Then C.Add rg(i, j).Value2
Next j
For k = 3 To C.Count
lRow = .Cells(Rows.Count, 4).End(xlUp).Row + 1
.Cells(lRow, 4) = C(1)
.Cells(lRow, 5) = C(2)
.Cells(lRow, 6) = C(k)
Next k
Set C = Nothing
Next i
End With
End With
End Sub

Display More

KathCobb · May 2nd 2020

Is there anyway you could comment this out for me. It's doing something, just not the correct thing. I should have mentioned that I do also have data in columns A though C. I see that your code says assumes data begins A1. The data that needs rearranging begins in D1. What would I change for this?

Thank you so much for what you have provided so far.

dangelor · May 2nd 2020

A small change and added comments...

Code

Sub Find_and_Move_Data()
Dim C As Collection
Dim rg As Range
Dim i As Long, j As Long
Dim k As Long, lRow As Long
With ThisWorkbook
'define working data
Set rg = .Worksheets("Sheet1").Cells(1, 4).CurrentRegion
'create worksheet to hold results
.Worksheets.Add Before:=.Worksheets(1)
'the new worksheet
With Worksheets(1)
'copy header row to new worksheet
rg.Rows(1).Copy .Cells(1, 1)
'cycle through data row by row, and column by column
For i = 2 To rg.Rows.count 'skip header row
Set C = New Collection
For j = 4 To rg.Columns.count 'changed to skip columns A,B and C
'places the row's data into a collection, ignoring blank cells
If Not IsEmpty(rg(i, j)) Then C.Add rg(i, j).Value2
Next j
'cycle through the collection
For k = 3 To C.count
lRow = .Cells(.Rows.count, 4).End(xlUp).Row + 1 'next empty row
.Cells(lRow, 4) = C(1) 'copies master number every time
.Cells(lRow, 5) = C(2) 'copies misc info every time
.Cells(lRow, 6) = C(k) 'copies a different name every time
Next k 'incrementing this to get all names
Set C = Nothing 'clears collection
Next i 'and starts over in the next row of data
End With
End With
End Sub

Display More

It would be easier if you could provide a workbook with 'dummy' data to test the code.

Vba code to find columns with any data move over to copy data then insert row below and paste both items

Share

Tags