VBA required for Columns to rows

N

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
210
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Here are the requirements I am trying to figure out a VBA code for.
Please help write a VBA code based on the requirements below.
Thank you.

Copy from WRKBOOK 1 to WRKBOOK 2
WRKBOOK 1 Columns G, H, I, J - Must create a new line if there is an entry, as shown in WRKBOOK 2
WRKBOOK 2 Columns A, B, C, D, E, F remains the same, only the quantity changes
Want an easy-to-modify VBA script so if there are additional columns added after WRKBOOK 1 Col F, or I, or j etc., can be easily modified.

EXAMPLEEXAMPLEEXAMPLEEXAMPLEEXAMPLEEXAMPLEcode1code2code3code4
TYPEstateZONEabs1respemsDOA
LINEDIGITNOMAutoAutoAutoQTYQTYQTYQTY
111111SmithteaBCred29
244444DrumphsnodDEorange1
356789ChuckdokZAblue1235
WRKBOOK 1


LINEDIGITNOMTYPESTATEZONEDIRQTY*
111111SmithteaBCredabs12
111111SmithteaBCredems9
244444DrumphsnodDEorangeems1
356789ChuckdokZAblueabs11
356789ChuckdokZAblueresp2
356789ChuckdokZAblueems3
356789ChuckdokZAblueDOA5
WRKBOOK 2
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Sort by date Sort by votes
An altetnative to VBA is Power Query. Here is the Mcode for that and the output

Power Query: 
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Transposed Table" = Table.Transpose(Source),
    #"Merged Columns" = Table.CombineColumns(#"Transposed Table",{"Column1", "Column2", "Column3"},Combiner.CombineTextByDelimiter(":", QuoteStyle.None),"Merged"),
    #"Transposed Table1" = Table.Transpose(#"Merged Columns"),
    #"Promoted Headers" = Table.PromoteHeaders(#"Transposed Table1", [PromoteAllScalars=true]),
    #"Changed Type" = Table.TransformColumnTypes(#"Promoted Headers",{{"EXAMPLE::LINE", Int64.Type}, {"EXAMPLE::DIGIT", Int64.Type}, {"EXAMPLE::NOM", type text}, {"EXAMPLE:TYPE:Auto", type text}, {"EXAMPLE:state:Auto", type text}, {"EXAMPLE:ZONE:Auto", type text}, {"code1:abs1:QTY", Int64.Type}, {"code2:resp:QTY", Int64.Type}, {"code3:ems:QTY", Int64.Type}, {"code4:DOA:QTY", Int64.Type}}),
    #"Filtered Rows" = Table.SelectRows(#"Changed Type", each ([#"EXAMPLE::LINE"] <> null)),
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Filtered Rows", {"EXAMPLE::LINE", "EXAMPLE::DIGIT", "EXAMPLE::NOM", "EXAMPLE:TYPE:Auto", "EXAMPLE:state:Auto", "EXAMPLE:ZONE:Auto"}, "Attribute", "Value"),
    #"Extracted Text Between Delimiters" = Table.TransformColumns(#"Unpivoted Other Columns", {{"Attribute", each Text.BetweenDelimiters(_, ":", ":"), type text}}),
    #"Renamed Columns" = Table.RenameColumns(#"Extracted Text Between Delimiters",{{"EXAMPLE::LINE", "LINE"}, {"EXAMPLE::DIGIT", "DIGIT"}, {"EXAMPLE::NOM", "NOM"}, {"EXAMPLE:TYPE:Auto", "TYPE"}, {"EXAMPLE:state:Auto", "STATE"}, {"EXAMPLE:ZONE:Auto", "ZONE"}, {"Attribute", "DIR"}, {"Value", "QTY"}})
in
    #"Renamed Columns"

Book3
ABCDEFGH
1LINEDIGITNOMTYPESTATEZONEDIRQTY
2111111SmithteaBCredabs12
3111111SmithteaBCredems9
4244444DrumphsnodDEorangeems1
5356789ChuckdokZAblueabs11
6356789ChuckdokZAblueresp2
7356789ChuckdokZAblueems3
8356789ChuckdokZAblueDOA5
Table1


Look at the link in my signature to learn more about Power Query
 
Upvote 0
alansidman said:
An altetnative to VBA is Power Query. Here is the Mcode for that and the output

Power Query: 
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Transposed Table" = Table.Transpose(Source),
    #"Merged Columns" = Table.CombineColumns(#"Transposed Table",{"Column1", "Column2", "Column3"},Combiner.CombineTextByDelimiter(":", QuoteStyle.None),"Merged"),
    #"Transposed Table1" = Table.Transpose(#"Merged Columns"),
    #"Promoted Headers" = Table.PromoteHeaders(#"Transposed Table1", [PromoteAllScalars=true]),
    #"Changed Type" = Table.TransformColumnTypes(#"Promoted Headers",{{"EXAMPLE::LINE", Int64.Type}, {"EXAMPLE::DIGIT", Int64.Type}, {"EXAMPLE::NOM", type text}, {"EXAMPLE:TYPE:Auto", type text}, {"EXAMPLE:state:Auto", type text}, {"EXAMPLE:ZONE:Auto", type text}, {"code1:abs1:QTY", Int64.Type}, {"code2:resp:QTY", Int64.Type}, {"code3:ems:QTY", Int64.Type}, {"code4:DOA:QTY", Int64.Type}}),
    #"Filtered Rows" = Table.SelectRows(#"Changed Type", each ([#"EXAMPLE::LINE"] <> null)),
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Filtered Rows", {"EXAMPLE::LINE", "EXAMPLE::DIGIT", "EXAMPLE::NOM", "EXAMPLE:TYPE:Auto", "EXAMPLE:state:Auto", "EXAMPLE:ZONE:Auto"}, "Attribute", "Value"),
    #"Extracted Text Between Delimiters" = Table.TransformColumns(#"Unpivoted Other Columns", {{"Attribute", each Text.BetweenDelimiters(_, ":", ":"), type text}}),
    #"Renamed Columns" = Table.RenameColumns(#"Extracted Text Between Delimiters",{{"EXAMPLE::LINE", "LINE"}, {"EXAMPLE::DIGIT", "DIGIT"}, {"EXAMPLE::NOM", "NOM"}, {"EXAMPLE:TYPE:Auto", "TYPE"}, {"EXAMPLE:state:Auto", "STATE"}, {"EXAMPLE:ZONE:Auto", "ZONE"}, {"Attribute", "DIR"}, {"Value", "QTY"}})
in
    #"Renamed Columns"

Book3
ABCDEFGH
1LINEDIGITNOMTYPESTATEZONEDIRQTY
2111111SmithteaBCredabs12
3111111SmithteaBCredems9
4244444DrumphsnodDEorangeems1
5356789ChuckdokZAblueabs11
6356789ChuckdokZAblueresp2
7356789ChuckdokZAblueems3
8356789ChuckdokZAblueDOA5
Table1


Look at the link in my signature to learn more about Power Query
Click to expand...

alansidman​

I really appreciate the work and the code you have compiled. I have never heard of Power Query until now. I'll try to figure out how to use it. Learn something new everyday. Thanks.
 
Upvote 0
Additionally, if you are serious about learning this powerful part of Excel, then grab a copy of the book " M is for (Data) Monkey" by Ken Puls and Miguel Escobar.
 
Upvote 0
Formula Option for auto update

WRKBOOK 2.xlsx
ABCDEFGH
1LINEDIGITNOMTYPESTATEZONEDIRQTY*
2111111SmithteaBCredabs12
3111111SmithteaBCredems9
4244444DrumphsnodDEorangeems1
5356789ChuckdokZAblueabs11
6356789ChuckdokZAblueresp2
7356789ChuckdokZAblueems3
8356789ChuckdokZAblueDOA5
Sheet1
Cell Formulas
RangeFormula
A2:F8A2=IFERROR(INDEX('[WRKBOOK 1.xlsx]Sheet1'!A$5:A$7,CEILING(AGGREGATE(15,6,((COLUMN('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)-COLUMN('[WRKBOOK 1.xlsx]Sheet1'!$G$5))+((ROW('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)-ROW('[WRKBOOK 1.xlsx]Sheet1'!$G$5))*COLUMNS('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)+1))/--('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7<>0),ROWS($A$2:A2)),COLUMNS('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7))/COLUMNS('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7),1),"")
G2:G8G2=IFERROR(INDEX('[WRKBOOK 1.xlsx]Sheet1'!$G$2:$J$2,1,MOD(AGGREGATE(15,6,((COLUMN('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)-COLUMN('[WRKBOOK 1.xlsx]Sheet1'!$G$5))+((ROW('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)-ROW('[WRKBOOK 1.xlsx]Sheet1'!$G$5))*COLUMNS('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)+1))/--('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7<>0),ROWS($G$2:G2))-1,COLUMNS('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7))+1),"")
H2:H8H2=IFERROR(INDEX('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7,CEILING(AGGREGATE(15,6,((COLUMN('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)-COLUMN('[WRKBOOK 1.xlsx]Sheet1'!$G$5))+((ROW('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)-ROW('[WRKBOOK 1.xlsx]Sheet1'!$G$5))*COLUMNS('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)+1))/--('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7<>0),ROWS($H$2:H2)),COLUMNS('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7))/COLUMNS('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7),MOD(AGGREGATE(15,6,((COLUMN('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)-COLUMN('[WRKBOOK 1.xlsx]Sheet1'!$G$5))+((ROW('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)-ROW('[WRKBOOK 1.xlsx]Sheet1'!$G$5))*COLUMNS('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7)+1))/--('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7<>0),ROWS($H$2:H2))-1,COLUMNS('[WRKBOOK 1.xlsx]Sheet1'!$G$5:$J$7))+1),"")
 
Upvote 0
Sorry, did you mean by WORKBOOK 1 and WORKBOOK 2 separated Excel files or One Excel file with 2 worksheets named as worksheets("WORKBOOK 1") and worksheets("WORKBOOK 2")


for One File with Tow Sheets
WRKBOOK 1.xlsx
ABCDEFGH
1LINEDIGITNOMTYPESTATEZONEDIRQTY*
2111111SmithteaBCredabs12
3111111SmithteaBCredems9
4244444DrumphsnodDEorangeems1
5356789ChuckdokZAblueabs11
6356789ChuckdokZAblueresp2
7356789ChuckdokZAblueems3
8356789ChuckdokZAblueDOA5
WRKBOOK 2
Cell Formulas
RangeFormula
A2:F8A2=IFERROR(INDEX('WRKBOOK 1'!A$5:A$7,CEILING(AGGREGATE(15,6,((COLUMN('WRKBOOK 1'!$G$5:$J$7)-COLUMN('WRKBOOK 1'!$G$5))+((ROW('WRKBOOK 1'!$G$5:$J$7)-ROW('WRKBOOK 1'!$G$5))*COLUMNS('WRKBOOK 1'!$G$5:$J$7)+1))/--('WRKBOOK 1'!$G$5:$J$7<>0),ROWS($A$2:A2)),COLUMNS('WRKBOOK 1'!$G$5:$J$7))/COLUMNS('WRKBOOK 1'!$G$5:$J$7),1),"")
G2:G8G2=IFERROR(INDEX('WRKBOOK 1'!$G$2:$J$2,1,MOD(AGGREGATE(15,6,((COLUMN('WRKBOOK 1'!$G$5:$J$7)-COLUMN('WRKBOOK 1'!$G$5))+((ROW('WRKBOOK 1'!$G$5:$J$7)-ROW('WRKBOOK 1'!$G$5))*COLUMNS('WRKBOOK 1'!$G$5:$J$7)+1))/--('WRKBOOK 1'!$G$5:$J$7<>0),ROWS($G$2:G2))-1,COLUMNS('WRKBOOK 1'!$G$5:$J$7))+1),"")
H2:H8H2=IFERROR(INDEX('WRKBOOK 1'!$G$5:$J$7,CEILING(AGGREGATE(15,6,((COLUMN('WRKBOOK 1'!$G$5:$J$7)-COLUMN('WRKBOOK 1'!$G$5))+((ROW('WRKBOOK 1'!$G$5:$J$7)-ROW('WRKBOOK 1'!$G$5))*COLUMNS('WRKBOOK 1'!$G$5:$J$7)+1))/--('WRKBOOK 1'!$G$5:$J$7<>0),ROWS($H$2:H2)),COLUMNS('WRKBOOK 1'!$G$5:$J$7))/COLUMNS('WRKBOOK 1'!$G$5:$J$7),MOD(AGGREGATE(15,6,((COLUMN('WRKBOOK 1'!$G$5:$J$7)-COLUMN('WRKBOOK 1'!$G$5))+((ROW('WRKBOOK 1'!$G$5:$J$7)-ROW('WRKBOOK 1'!$G$5))*COLUMNS('WRKBOOK 1'!$G$5:$J$7)+1))/--('WRKBOOK 1'!$G$5:$J$7<>0),ROWS($H$2:H2))-1,COLUMNS('WRKBOOK 1'!$G$5:$J$7))+1),"")
 
Upvote 0
What about this Macro:
VBA Code: 
Sub TransferData()
Dim I as Long, Lr1 as Long, Lr2 as Long, C as Long, j as long, k as long
Dim Sh1 as worksheet, Sh2 as worksheet, Wb1 as workbook, Wb2 as workbook
Application.ScreenUpdating = False
'Set wb1 = Workbooks("Book1.xlsx")
'Set wb2 = Workbooks("Book2.xlsx")
Set Sh1 = Sheets("Sheet1")        'With Workbook this is     Set Sh1 = wb1.Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")        'With Workbook this is     Set Sh2 = wb2.Sheets("Sheet1")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlup).Row
Sh2.Range("A1:C1").Value = Sh1.Range("A3:C3").Value
Sh2.Range("D1:F1").Value = Sh1.Range("D2:F2").Value
Sh2.Range("G1").Value = "DIR"
Sh2.Range("H1").Value = "QTY"
For I=5 to Lr1
Lr2 = Sh2.Cells(Rows.Count, 1).End(xlup).Row + 1
C = Application.worksheetfunction.Count(Sh1.Range("G" & I & ":J" & I))
Sh2.Range("A" &Lr2 + 1 & ":F" & Lr2 + C)).Value = Sh1.Range("A" & I & ":F" & I).Value
k = 1
For j=7 to 10
if Sh1.Cells(I, j).Value = "" Then
Else
Sh2.Range("G" &Lr2 + k) = Sh1.Cells(2, j)
Sh2.Range("H" &Lr2 + k) = Sh1.Cells(I, j)
k = k + 1
End if
Next j
Next I
Application.ScreenUpdating = True
End Sub
 
Last edited by a moderator:
Upvote 0
Dossfm0q said:
Sorry, did you mean by WORKBOOK 1 and WORKBOOK 2 separated Excel files or One Excel file with 2 worksheets named as worksheets("WORKBOOK 1") and worksheets("WORKBOOK 2")


for One File with Tow Sheets
WRKBOOK 1.xlsx
ABCDEFGH
1LINEDIGITNOMTYPESTATEZONEDIRQTY*
2111111SmithteaBCredabs12
3111111SmithteaBCredems9
4244444DrumphsnodDEorangeems1
5356789ChuckdokZAblueabs11
6356789ChuckdokZAblueresp2
7356789ChuckdokZAblueems3
8356789ChuckdokZAblueDOA5
WRKBOOK 2
Cell Formulas
RangeFormula
A2:F8A2=IFERROR(INDEX('WRKBOOK 1'!A$5:A$7,CEILING(AGGREGATE(15,6,((COLUMN('WRKBOOK 1'!$G$5:$J$7)-COLUMN('WRKBOOK 1'!$G$5))+((ROW('WRKBOOK 1'!$G$5:$J$7)-ROW('WRKBOOK 1'!$G$5))*COLUMNS('WRKBOOK 1'!$G$5:$J$7)+1))/--('WRKBOOK 1'!$G$5:$J$7<>0),ROWS($A$2:A2)),COLUMNS('WRKBOOK 1'!$G$5:$J$7))/COLUMNS('WRKBOOK 1'!$G$5:$J$7),1),"")
G2:G8G2=IFERROR(INDEX('WRKBOOK 1'!$G$2:$J$2,1,MOD(AGGREGATE(15,6,((COLUMN('WRKBOOK 1'!$G$5:$J$7)-COLUMN('WRKBOOK 1'!$G$5))+((ROW('WRKBOOK 1'!$G$5:$J$7)-ROW('WRKBOOK 1'!$G$5))*COLUMNS('WRKBOOK 1'!$G$5:$J$7)+1))/--('WRKBOOK 1'!$G$5:$J$7<>0),ROWS($G$2:G2))-1,COLUMNS('WRKBOOK 1'!$G$5:$J$7))+1),"")
H2:H8H2=IFERROR(INDEX('WRKBOOK 1'!$G$5:$J$7,CEILING(AGGREGATE(15,6,((COLUMN('WRKBOOK 1'!$G$5:$J$7)-COLUMN('WRKBOOK 1'!$G$5))+((ROW('WRKBOOK 1'!$G$5:$J$7)-ROW('WRKBOOK 1'!$G$5))*COLUMNS('WRKBOOK 1'!$G$5:$J$7)+1))/--('WRKBOOK 1'!$G$5:$J$7<>0),ROWS($H$2:H2)),COLUMNS('WRKBOOK 1'!$G$5:$J$7))/COLUMNS('WRKBOOK 1'!$G$5:$J$7),MOD(AGGREGATE(15,6,((COLUMN('WRKBOOK 1'!$G$5:$J$7)-COLUMN('WRKBOOK 1'!$G$5))+((ROW('WRKBOOK 1'!$G$5:$J$7)-ROW('WRKBOOK 1'!$G$5))*COLUMNS('WRKBOOK 1'!$G$5:$J$7)+1))/--('WRKBOOK 1'!$G$5:$J$7<>0),ROWS($H$2:H2))-1,COLUMNS('WRKBOOK 1'!$G$5:$J$7))+1),"")
Click to expand...

maabadi said:
What about this Macro:
VBA Code: 
Sub TransferData()
Dim I as Long, Lr1 as Long, Lr2 as Long, C as Long, j as long, k as long
Dim Sh1 as worksheet, Sh2 as worksheet, Wb1 as workbook, Wb2 as workbook
Application.ScreenUpdating = False
'Set wb1 = Workbooks("Book1.xlsx")
'Set wb2 = Workbooks("Book2.xlsx")
Set Sh1 = Sheets("Sheet1")        'With Workbook this is     Set Sh1 = wb1.Sheets("Sheet1")
Set Sh2 = Sheets("Sheet2")        'With Workbook this is     Set Sh2 = wb2.Sheets("Sheet1")
Lr1 = Sh1.Cells(Rows.Count, 1).End(xlup).Row
Sh2.Range("A1:C1").Value = Sh1.Range("A3:C3").Value
Sh2.Range("D1:F1").Value = Sh1.Range("D2:F2").Value
Sh2.Range("G1").Value = "DIR"
Sh2.Range("H1").Value = "QTY"
For I=5 to Lr1
Lr2 = Sh2.Cells(Rows.Count, 1).End(xlup).Row + 1
C = Application.worksheetfunction.Count(Sh1.Range("G" & I & ":J" & I))
Sh2.Range("A" &Lr2 + 1 & ":F" & Lr2 + C)).Value = Sh1.Range("A" & I & ":F" & I).Value
k = 1
For j=7 to 10
if Sh1.Cells(I, j).Value = "" Then
Else
Sh2.Range("G" &Lr2 + k) = Sh1.Cells(2, j)
Sh2.Range("H" &Lr2 + k) = Sh1.Cells(I, j)
k = k + 1
End if
Next j
Next I
Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you so much for taking the time to create this VBA code!!!
I will test it out later and see.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
Comparing 3 tables to a list of numbers, if match, return 4 columns worth of data on another tab
Replies
4
Views
157
alansidman
A
T
  • Solved
MATCH function
2
Replies
14
Views
259
Fluff
Fluff
M
  • Question
Stack/Combine multiple columns into one column
Replies
4
Views
173
myall_blues
myall_blues
M
  • Question
VBA Code to copy rows by date from one tab to another / repeat based on new date
Replies
3
Views
301
kevin9999
K
E
  • Question
Estimating Spreadsheet-Summing
Replies
1
Views
183
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,216,095
Messages
6,128,795
Members
449,468
Latest member
AGreen17

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