VBA required for Columns to rows

NeoSez · Jan 6, 2021

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.



EXAMPLE	EXAMPLE	EXAMPLE	EXAMPLE	EXAMPLE	EXAMPLE	code1	code2	code3	code4
			TYPE	state	ZONE	abs1	resp	ems	DOA
LINE	DIGIT	NOM	Auto	Auto	Auto	QTY	QTY	QTY	QTY

1	11111	Smith	tea	BC	red	2		9
2	44444	Drumph	snod	DE	orange			1
3	56789	Chuck	dok	ZA	blue	1	2	3	5
WRKBOOK 1

LINE DIGIT NOM TYPE STATE ZONE DIR QTY*
1 11111 Smith tea BC red abs1 2
1 11111 Smith tea BC red ems 9
2 44444 Drumph snod DE orange ems 1
3 56789 Chuck dok ZA blue abs1 1
3 56789 Chuck dok ZA blue resp 2
3 56789 Chuck dok ZA blue ems 3
3 56789 Chuck dok ZA blue DOA 5
WRKBOOK 2

alansidman · Jan 6, 2021

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

A

B

C

D

E

F

G

H

1

LINE

DIGIT

NOM

TYPE

STATE

ZONE

DIR

QTY

2

1

11111

Smith

tea

BC

red

abs1

2

3

1

11111

Smith

tea

BC

red

ems

9

4

2

44444

Drumph

snod

DE

orange

ems

1

5

3

56789

Chuck

dok

ZA

blue

abs1

1

6

3

56789

Chuck

dok

ZA

blue

resp

2

7

3

56789

Chuck

dok

ZA

blue

ems

3

8

3

56789

Chuck

dok

ZA

blue

DOA

5

Table1

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

NeoSez · Jan 6, 2021

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

A

B

C

D

E

F

G

H

1

LINE

DIGIT

NOM

TYPE

STATE

ZONE

DIR

QTY

2

1

11111

Smith

tea

BC

red

abs1

2

3

1

11111

Smith

tea

BC

red

ems

9

4

2

44444

Drumph

snod

DE

orange

ems

1

5

3

56789

Chuck

dok

ZA

blue

abs1

1

6

3

56789

Chuck

dok

ZA

blue

resp

2

7

3

56789

Chuck

dok

ZA

blue

ems

3

8

3

56789

Chuck

dok

ZA

blue

DOA

5

Table1

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

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.

alansidman · Jan 7, 2021

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.

NeoSez · Jan 12, 2021

NeoSez said:
alansidman I don't know where to insert the code. Can you tell me where to add this code? Thank you.

NeoSez said:
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.

Dossfm0q · Jan 13, 2021

Formula Option for auto update

WRKBOOK 2.xlsx

A

B

C

D

E

F

G

H

1

LINE

DIGIT

NOM

TYPE

STATE

ZONE

DIR

QTY*

2

3

4

5

6

7

8

Sheet1

Cell Formulas
Range	Formula
A2:F8	A2	=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:G8	G2	=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:H8	H2	=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),"")

Dossfm0q · Jan 13, 2021

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

A

B

C

D

E

F

G

H

1

LINE

DIGIT

NOM

TYPE

STATE

ZONE

DIR

QTY*

2

3

4

5

6

7

8

WRKBOOK 2

Cell Formulas
Range	Formula
A2:F8	A2	=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:G8	G2	=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:H8	H2	=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),"")

maabadi · Jan 13, 2021

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

alansidman · Jan 13, 2021

- Follow this link for a video which demonstrates how to use Power Query code provided.

NeoSez · Jan 13, 2021

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
A B C D E F G H
1 LINE DIGIT NOM TYPE STATE ZONE DIR QTY*
2 1 11111 Smith tea BC red abs1 2
3 1 11111 Smith tea BC red ems 9
4 2 44444 Drumph snod DE orange ems 1
5 3 56789 Chuck dok ZA blue abs1 1
6 3 56789 Chuck dok ZA blue resp 2
7 3 56789 Chuck dok ZA blue ems 3
8 3 56789 Chuck dok ZA blue DOA 5
WRKBOOK 2
Cell Formulas
Range Formula
A2:F8 A2 =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:G8 G2 =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:H8 H2 =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),"")

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

Thank you so much for taking the time to create this VBA code!!!
I will test it out later and see.

VBA required for Columns to rows

NeoSez

Board Regular

Excel Facts

alansidman

Well-known Member

NeoSez

Board Regular

alansidman

alansidman

Well-known Member

NeoSez

Board Regular

alansidman I don't know where to insert the code. Can you tell me where to add this code? Thank you.

alansidman

Dossfm0q

Banned User

Dossfm0q

Banned User

maabadi

Well-known Member

alansidman

Well-known Member

NeoSez

Board Regular

Similar threads

Forum statistics

Share this page

VBA required for Columns to rows

Board Regular

Excel Facts

Well-known Member

Board Regular

alansidman​

Well-known Member

Board Regular

alansidman I don't know where to insert the code. Can you tell me where to add this code? Thank you.​

alansidman​

Banned User

Banned User

Well-known Member

Well-known Member

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock

alansidman

alansidman I don't know where to insert the code. Can you tell me where to add this code? Thank you.

alansidman