VBA: Transfer & Transposing

N

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
246
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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!

ABCDEFGHIJKLM
COL GCOLHCOL ICOL JCOL KCOL LCOL M
ALPHABETAGAMMADELTAEPSILONZETAETA
COL ACOL BCOL CCOL DCOL ECOL FEnter QTYEnter QTYEnter QTYEnter QTYEnter QTYEnter QTYEnter QTY
1bghijklm
1cnost
Sheet1


ABETAC D
FFFGGG PRICE
COL GALPHA$100.00
COLHBETA$101.00
COL IGAMMA$102.00
COL JDELTA$103.00
COL KEPSILON$104.00
COL LZETA$105.00
COL META$106.00
SHEET2


BCDEQRVW
BBBCCCDDDEEEFFFGGGHHHPrice* (From Sample Original|Sheet2)
1bCOL GALPHAg$ 100.00
2bCOLHBETAh$ 101.00
3bCOL IGAMMAi$ 102.00
4bCOL JDELTAj$ 103.00
5bCOL KEPSILONk$ 104.00
6bCOL LZETAl$ 105.00
7bCOL METAm$ 106.00
Numbering restarts with each new item from Sheet 1 Col BINSERT BLANK LINE FOR NEW 'COL B' ROW#N/A#N/A
1cCOL GALPHAn$ 100.00
2cCOLHBETAo$ 101.00
3cCOL LZETAs$ 105.00
4cCOL METAt$ 106.00
Final Transposed Results
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
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?
 
Upvote 0
I assume the 3rd sheet's name is "Sheet3".
Try the code below in a standard module:
VBA Code: 
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
 
Last edited:
Upvote 0
kanadaaa said:
I assume the 3rd sheet's name is "Sheet3".
Try the code below in a standard module:
VBA Code: 
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
Click to expand...

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.
 
Upvote 0
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.
 
Upvote 0
kanadaaa said:
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.
Click to expand...
kanadaaa said:
Then I need the full path of the first workbook.
Click to expand...
SAMPLE Original.xlsx

Also I need the exact sheet name of Sheet3.-> TRANSX
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question Question
VBA required for Transposing COL to ROW
Replies
1
Views
395
NeoSez
N
G
  • Locked
  • Question Question
Transfer Data From Multiple Rows to one Column (Transpose form)
Replies
6
Views
380
Fluff
Fluff
Geeta2014
  • Question Question
Vba to 1) Add and 2) Delete rows based on Criteria entered in input box that displays on screen
Replies
3
Views
550
igold
igold
B
  • Question Question
Transpose Columns To Rows And Insert New Rows To Fill Down Data with VBA
Replies
4
Views
6K
Brandoe
B
K
  • Question Question
VBA Loop through Column
Replies
7
Views
4K
mse330
M

Forum statistics

Threads
1,223,894
Messages
6,175,250
Members
452,623
Latest member
Techenthusiast

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