VBA: Transfer & Transposing

[NeoSez]

Would like some help with a VBA script to transfer data as shown below.
I tried to make it as simple as possible below.
Sheet1: COL G-M may not always contain complete data. Therefore, only transfer the cells with actual data as a new row. See Sheet2 for how it is to look.
The final result is the last table. I hope the tables are self explanatory. They say a picture is worth a thousand words and I'm sure nobody wants to read a thousand word of explanations.
I f you require further clarification, please ask away and I will try to explain it better.
I'm still very new with VBA so hoping that someone can help provide me with a VBA that I can easily learn to change for future uses.
Thank you!

A	B	C	D	E	F	G	H	I	J	K	L	M
						COL G	COLH	COL I	COL J	COL K	COL L	COL M
						ALPHA	BETA	GAMMA	DELTA	EPSILON	ZETA	ETA
COL A	COL B	COL C	COL D	COL E	COL F	Enter QTY	Enter QTY	Enter QTY	Enter QTY	Enter QTY	Enter QTY	Enter QTY
1	b					g	h	i	j	k	l	m
1	c					n	o				s	t
Sheet1

A	BETA	C	D
FFF	GGG		PRICE
COL G	ALPHA		$100.00
COLH	BETA		$101.00
COL I	GAMMA		$102.00
COL J	DELTA		$103.00
COL K	EPSILON		$104.00
COL L	ZETA		$105.00
COL M	ETA		$106.00
SHEET2

B	C	D	E												Q	R				V	W
BBB	CCC	DDD	EEE												FFF	GGG				HHH	Price* (From Sample Original|Sheet2)
1	b														COL G	ALPHA				g	$ 100.00
2	b														COLH	BETA				h	$ 101.00
3	b														COL I	GAMMA				i	$ 102.00
4	b														COL J	DELTA				j	$ 103.00
5	b														COL K	EPSILON				k	$ 104.00
6	b														COL L	ZETA				l	$ 105.00
7	b														COL M	ETA				m	$ 106.00
Numbering restarts with each new item from Sheet 1 Col B	INSERT BLANK LINE FOR NEW 'COL B' ROW	#N/A	#N/A
1	c														COL G	ALPHA				n	$ 100.00
2	c														COLH	BETA				o	$ 101.00
3	c														COL L	ZETA				s	$ 105.00
4	c														COL M	ETA				t	$ 106.00
Final Transposed Results

 

[kanadaaa]

Hi, what's the sheet name of the 3rd picture?
And I guess "Final Transposed Results" typed into the cell is only for the purpose of explanation, but is there any nonempty cell below the line that has the values "4" and "c" (the row immediately above the FTR cell) on the actual worksheet?

 

[kanadaaa]

I assume the 3rd sheet's name is "Sheet3".
Try the code below in a standard module:

Sub TransferValues()
    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
    Dim lr1 As Long, lr2 As Long, lr3 As Long
    Dim cell As Range, fnd As Range, i As Long, arr(3) As String
 
    Application.ScreenUpdating = False 'Make the code faster
 
    Set sh1 = Worksheets("Sheet1") 'Substitute worksheet variable
    Set sh2 = Worksheets("Sheet2") 'Substitute worksheet variable
    Set sh3 = Worksheets("Sheet3") 'Substitute worksheet variable <=CHANGE THE SHEET NAME IF THIS ISN'T ACCURATE
    lr1 = sh1.Cells(Rows.Count, "B").End(xlUp).Row 'Get the row number of the last nonempty cell on Sheet1
    lr2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row 'Get the row number of the last nonempty cell on Sheet2
    lr3 = sh3.Cells(Rows.Count, "B").End(xlUp).Row + 2 'Get the row number of the last nonempty cell on Sheet3 and get the row number into which data should be transferred
 
    For Each cell In Range(sh1.Cells(lr1, "G"), sh1.Cells(lr1, "M")) 'Check every cell in columns G-M in the row
        If cell <> "" Then 'If the relevant cell is not empty
            With sh3
                             
                Set fnd = Range(sh2.Cells(2, "A"), sh2.Cells(lr2, "A")).Find(sh1.Cells(1, cell.Column).Value, , xlValues, xlWhole) 'Check if "COL X" exists in the table on sh2
                If fnd Is Nothing Then 'If "COL X" doesn't exist in the table
                    'Set the entries of the array to be used later when values are transferred to sh3
                    For i = 0 To 3
                        If i <> 2 Then
                            arr(i) = "N/A"
                        Else
                            arr(i) = cell.Value
                        End If
                        '↑e.g. arr(0) = "N/A", arr(1) = "N/A", arr(2) = "n", arr(3) = "N/A"
                    Next i
                Else 'If "COL X" DOES exist in the table
                    For i = 0 To 3
                        arr(i) = Choose(i + 1, fnd.Value, fnd.Offset(, 1).Value, cell.Value, fnd.Offset(, 3).Text) 'e.g. arr(0) = "COL G", arr(1) = "ALPHA", arr(2) = "n", arr(3) = "$100.00"
                    Next i
                End If
             
                'Transfer values
                .Cells(lr3, "B") = WorksheetFunction.CountIf(.Range("C2:C" & Rows.Count), sh1.Cells(lr1, "B").Value) + 1 'Count the number of the value in COL B on sh1
                .Cells(lr3, "C") = sh1.Cells(lr1, "B") 'Transfer the cell value in column B on sh1 to column C on sh3
                .Cells(lr3, "Q") = arr(0)
                .Cells(lr3, "R") = arr(1)
                .Cells(lr3, "V") = arr(2)
                .Cells(lr3, "W") = arr(3)
             
                'Substitute values for the next iteration
                Erase arr 'Empty the array
                lr3 = lr3 + 1 'Add 1 to go on to the next row on sh3
             
            End With
        End If
    Next cell
 
    Application.ScreenUpdating = True 'Reset the macro optimization setting
    MsgBox "Data sucessfully transferred."
 
End Sub

 

[NeoSez]

I assume the 3rd sheet's name is "Sheet3".
Try the code below in a standard module:

Sub TransferValues()
    Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
    Dim lr1 As Long, lr2 As Long, lr3 As Long
    Dim cell As Range, fnd As Range, i As Long, arr(3) As String
 
    Application.ScreenUpdating = False 'Make the code faster
 
    Set sh1 = Worksheets("Sheet1") 'Substitute worksheet variable
    Set sh2 = Worksheets("Sheet2") 'Substitute worksheet variable
    Set sh3 = Worksheets("Sheet3") 'Substitute worksheet variable <=CHANGE THE SHEET NAME IF THIS ISN'T ACCURATE
    lr1 = sh1.Cells(Rows.Count, "B").End(xlUp).Row 'Get the row number of the last nonempty cell on Sheet1
    lr2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row 'Get the row number of the last nonempty cell on Sheet2
    lr3 = sh3.Cells(Rows.Count, "B").End(xlUp).Row + 2 'Get the row number of the last nonempty cell on Sheet3 and get the row number into which data should be transferred
 
    For Each cell In Range(sh1.Cells(lr1, "G"), sh1.Cells(lr1, "M")) 'Check every cell in columns G-M in the row
        If cell <> "" Then 'If the relevant cell is not empty
            With sh3
                            
                Set fnd = Range(sh2.Cells(2, "A"), sh2.Cells(lr2, "A")).Find(sh1.Cells(1, cell.Column).Value, , xlValues, xlWhole) 'Check if "COL X" exists in the table on sh2
                If fnd Is Nothing Then 'If "COL X" doesn't exist in the table
                    'Set the entries of the array to be used later when values are transferred to sh3
                    For i = 0 To 3
                        If i <> 2 Then
                            arr(i) = "N/A"
                        Else
                            arr(i) = cell.Value
                        End If
                        '↑e.g. arr(0) = "N/A", arr(1) = "N/A", arr(2) = "n", arr(3) = "N/A"
                    Next i
                Else 'If "COL X" DOES exist in the table
                    For i = 0 To 3
                        arr(i) = Choose(i + 1, fnd.Value, fnd.Offset(, 1).Value, cell.Value, fnd.Offset(, 3).Text) 'e.g. arr(0) = "COL G", arr(1) = "ALPHA", arr(2) = "n", arr(3) = "$100.00"
                    Next i
                End If
            
                'Transfer values
                .Cells(lr3, "B") = WorksheetFunction.CountIf(.Range("C2:C" & Rows.Count), sh1.Cells(lr1, "B").Value) + 1 'Count the number of the value in COL B on sh1
                .Cells(lr3, "C") = sh1.Cells(lr1, "B") 'Transfer the cell value in column B on sh1 to column C on sh3
                .Cells(lr3, "Q") = arr(0)
                .Cells(lr3, "R") = arr(1)
                .Cells(lr3, "V") = arr(2)
                .Cells(lr3, "W") = arr(3)
            
                'Substitute values for the next iteration
                Erase arr 'Empty the array
                lr3 = lr3 + 1 'Add 1 to go on to the next row on sh3
            
            End With
        End If
    Next cell
 
    Application.ScreenUpdating = True 'Reset the macro optimization setting
    MsgBox "Data sucessfully transferred."
 
End Sub

kanadaaa​

Thank you so much for writing up a script so quickly. I just tried your script.

Does your script find and transfer based on the Actual Column Name or by the Column Lettering (ie. A, B, C...)? I'm hoping it finds and transfers by the Column Lettering as the people who named the columns are all over the place. This is probably why when I ran the script, it said "Data sucessfully transferred", but nothing was actually transferred? I did attempt to make some adjustments, but I failed.
Sheet1 data begins on row 8
Sheet2 data begins on row 9
Sheet3 data begins on row 8

Sheets 1&2 are actually in one Workbook (sorry, dind't realize the filename didn't show when I copy/pasted the table), that we'll call Workbook1. Sheet3 is in a different Workbook that we'll call Workbook2.
For the sake of this exercise, I've made a copy of Sheet3 in Workbook1 so everything is in one Workbook. I have had problems trying to pull data from different workbooks before.

 

[kanadaaa]

Then I need the full path of the first workbook.
For now, let's put aside those column things and see if the code works with the workbook specified.
Also I need the exact sheet name of Sheet3.

 

[NeoSez]

Then I need the full path of the first workbook.
For now, let's put aside those column things and see if the code works with the workbook specified.
Also I need the exact sheet name of Sheet3.

Then I need the full path of the first workbook.

SAMPLE Original.xlsx

Also I need the exact sheet name of Sheet3.-> TRANSX

 

[kanadaaa]

SAMPLE Original.xlsx

No, I need the PATH of the WORKBOOK, like C:\Users\...

 

[kanadaaa]

Just in case I'll share my sample workbook with the code in #3.

https://easyupload.io/phdlon

 

[NeoSez]

No, I need the PATH of the WORKBOOK, like C:\Users\...

Hi you can just add any path to the file for now. I will change it later to the correct path. Thank you.