Trying to copy multiple columns into one (specific) column

[sheri23110]

Zero VBA knowledge here. This code was found via a google search. After changing a few things, it does everything I need it to do with one exception:

I want to copy the data to a specific column. Currently the code copies the data into column A. I want to be able to specify the column.

Thank you for taking the time to help, and if there is an easier way to do this other than what is outlined below, please let me know.

Sub CopyColumnsToOneColumn()
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
Dim lastRow As Long
Dim destRow As Long
Dim col As Long
Dim i As Long

' Set your source and destination sheets
Set sourceSheet = ThisWorkbook.Sheets("testdata")
Set destinationSheet = ThisWorkbook.Sheets("test")

' Initialize the destination row
destRow = 2

' Loop through each column you want to copy
For col = 1 To 4 ' Adjust the range (1 To 4) to the columns you want to copy
' Find the last row in the current column
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, col).End(xlUp).Row

' Copy each cell from the current column to the destination column
For i = 2 To lastRow
destinationSheet.Cells(destRow, 1).Value = sourceSheet.Cells(i, col).Value
destRow = destRow + 1
Next i

Next col

MsgBox "Columns copied successfully!"
End Sub

 

[alansidman]

Use XL2BB to present a sample of your current data and then mock up what you want it to look like. Let us build a solution for you instead of trying to fix someone else code that does not do what you want.

 

[jolivanes]

Like Alan mentioned, help us helping you.
In the meantime you can try this, changed to fit your needs I think, which I just happened to have open for something else.
If it does not work, we'll wait for you answer to Post #2

Sub Maybe_So()
Dim alCols As Long, col As Long, lr As Long, i As Long, dataArr
lr = Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
alCols = Application.InputBox("How many columns to copy starting from column A?", "Number of columns to copy.", , , , , , 1)
col = Application.InputBox("Which numerical column number do you want to paste into?", "Numerical Column Number Required (A = 1, B = 2, C = 3 etc).", , , , , , 1)
dataArr = Cells(2, 1).Resize(lr - 1, col).Value
    For i = 1 To alCols
        Cells(Rows.Count, col).End(xlUp).Offset(1).Resize(lr - 1).Value = Application.Index(dataArr, 0, i)
    Next i
End Sub

 

[Micron]

If I may, please post more than a couple of lines of code within code tags (use vba button on posting toolbar) so that it looks like the following. I played with your actual code but used my own sheet names, so you'd have to restore yours. Not trying to one-up anybody here; I worked on it for practice and figure I might as well finish the task.

Sub copycolumnstoonecolumn()
Dim sourceSheet As Worksheet, destinationSheet As Worksheet
Dim lastRow As Long, destRow As Long, col As Long, i As Long
Dim rngDest As Range 'destination column

Set rngDest = Application.InputBox("Choose a cell in the column to paste into", Type:=8)
If rngDest Is Nothing Then
    MsgBox "Column selection was not made, so exiting..."
    Exit Sub
End If

' Set your source and destination sheets
Set sourceSheet = ThisWorkbook.Sheets("Sheet3")
Set destinationSheet = ThisWorkbook.Sheets("Query2")

' Initialize the destination row
destRow = 2

' Loop through each column you want to copy
For col = 1 To 4 ' Adjust the range (1 To 4) to the columns you want to copy
    ' Find the last row in the current column
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, col).End(xlUp).row

    ' Copy each cell from the current column to the destination column
    For i = 2 To lastRow
        destinationSheet.Cells(destRow, rngDest.Column).Value = sourceSheet.Cells(i, col).Value
        destRow = destRow + 1
        Debug.Print sourceSheet.Cells(i, col).Value
    Next i
Next col

MsgBox "Columns copied successfully!"

End Sub

EDIT - thought I had a non-response from inputbox covered but I see that I didn't nail that. Back to the drawing board...

 

[MARK858]

EDIT - thought I had a non-response from inputbox covered but I see that I didn't nail that. Back to the drawing board...

When using the range parameter in application.inputbox you need to deal with the error before you test for nothing one way is by wrapping the inputbox line in an On Error Resume Next / On Error Goto 0 then use your test for nothing.

If you wanted to avoid using error handling you could do something like the below, running copycolumnstoonecolumn()
Please note that I have changed the sheet names

Sub CheckSub(ByVal a As Variant, ByRef b As Range)
  If TypeOf a Is Range Then Set b = a
End Sub

Sub copycolumnstoonecolumn()
Dim sourceSheet As Worksheet, destinationSheet As Worksheet
Dim lastRow As Long, destRow As Long, col As Long, i As Long
Dim rngDest As Range 'destination column

CheckSub Application.InputBox("Choose a cell in the column to paste into", Type:=8), rngDest

If rngDest Is Nothing Then
    MsgBox "Column selection was not made, so exiting..."
    Exit Sub
End If

' Set your source and destination sheets
Set sourceSheet = ThisWorkbook.Sheets("testdata")
Set destinationSheet = ThisWorkbook.Sheets("test")

' Initialize the destination row
destRow = 2

' Loop through each column you want to copy
For col = 1 To 4 ' Adjust the range (1 To 4) to the columns you want to copy
    ' Find the last row in the current column
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, col).End(xlUp).Row

    ' Copy each cell from the current column to the destination column
    For i = 2 To lastRow
        destinationSheet.Cells(destRow, rngDest.Column).Value = sourceSheet.Cells(i, col).Value
        destRow = destRow + 1
        Debug.Print sourceSheet.Cells(i, col).Value
    Next i
Next col

MsgBox "Columns copied successfully!"

End Sub

 

[Peter_SSs]

Welcome to the MrExcel board!

1. Do you have blank cells in the data that you want to keep in the results?
2. Do you need vba?

If the answer to both is "No" then you could just go to where you want the results and enter this formula

=TOCOL(DROP(testdata!A:D,1),1,1)

If the answer to 1. is "No" but the answer to 2. is "Yes" then this would be another option without any looping.
Test any vba code with a copy of your workbook.

Sub To_Column()
  Dim sourceSheet As Worksheet, destinationSheet As Worksheet
  Dim TopAddr As String
  Dim TopCell As Range
  
  Const FirstCol As String = "A"  '<- First col to copy
  Const LastCol As String = "D"   '<- Last col to copy
  
  Set sourceSheet = ThisWorkbook.Sheets("testdata")
  Set destinationSheet = ThisWorkbook.Sheets("test")
  TopAddr = Application.InputBox(Prompt:="Input first result cell address on sheet " & destinationSheet.Name & " (eg D2)", Type:=2)
  On Error Resume Next
  Set TopCell = destinationSheet.Range(TopAddr)
  On Error GoTo 0
  If TopCell Is Nothing Then
    MsgBox "Invalid cell address. Nothing copied."
  Else
    With TopCell
      .Formula2 = "=TOCOL(DROP('" & sourceSheet.Name & "'!" & FirstCol & ":" & LastCol & ",1),1,1)"
      .SpillingToRange.Value = .SpillingToRange.Value
    End With
  End If
End Sub

If the answer to both is "Yes" then you could try this

Sub To_Column_v2()
  Dim sourceSheet As Worksheet, destinationSheet As Worksheet
  Dim TopAddr As String
  Dim TopCell As Range, Col As Range
  
  Const FirstCol As String = "A"  '<- First col to copy
  Const LastCol As String = "D"   '<- Last col to copy
  
  Set sourceSheet = ThisWorkbook.Sheets("testdata")
  Set destinationSheet = ThisWorkbook.Sheets("test")
  TopAddr = Application.InputBox(Prompt:="Input first result cell address on sheet " & destinationSheet.Name & " (eg D2)", Type:=2)
  On Error Resume Next
  Set TopCell = destinationSheet.Range(TopAddr)
  On Error GoTo 0
  If TopCell Is Nothing Then
    MsgBox "Invalid cell address. Nothing copied."
  Else
    Application.ScreenUpdating = False
    For Each Col In sourceSheet.Range(FirstCol & ":" & LastCol).Columns
      Col.Cells(2).Resize(Col.Cells(Rows.Count).End(xlUp).Row).Copy
      destinationSheet.Cells(Rows.Count, TopCell.Column).End(xlUp).Offset(1).PasteSpecial xlValues
    Next Col
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
  End If
End Sub

 

[Micron]

@MARK858

one way is by wrapping the inputbox line in an On Error Resume Next / On Error Goto 0 then use your test for nothing.

Found lots of examples of that, but they don't help with situation where user clicks OK. Depending on the variable type, I can get around that but dealing with OK with no range raises the "there is a problem with this formula" prompt. If I disable warnings the input repeatedly comes back. I can try your code but if you have comments on how to deal with both scenarios (OK with no selection, or Cancel) I'd be "all eyes" .
EDIT I see you used type 2 not 8

 

[jolivanes]

This line in Post #3

dataArr = Cells(2, 1).Resize(lr - 1, col).Value

should read

dataArr = Cells(2, 1).Resize(lr - 1, alCols).Value

 

[MARK858]

EDIT I see you used type 2 not 8

I didn't (the code I posted for the inputbox was copy/pasted from your code), Peter does in his code as he is using a string not the range

 

[jolivanes]

If you want to select cells to indicate copy range and paste column, this does that for you.

Sub Maybe_So_2()
Dim lastCol As Range, col As Range, lr As Long, i As Long, dataArr
lr = Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row

Application.DisplayAlerts = False
On Error Resume Next
    Set lastCol = Application.InputBox("Select a cell in the last column to be copied", "Cell Selection Required.", , , , , , 8)
On Error GoTo 0
Application.DisplayAlerts = True
If lastCol Is Nothing Then Exit Sub

Application.DisplayAlerts = False
On Error Resume Next
    Set col = Application.InputBox("Select a cell in the column where you want to paste into", "Cell Selection Required.", , , , , , 8)
On Error GoTo 0
Application.DisplayAlerts = True
If col Is Nothing Then Exit Sub

dataArr = Cells(2, 1).Resize(lr - 1, lastCol.Column).Value
    For i = 1 To UBound(dataArr, 2) 
        Cells(Rows.Count, col.Column).End(xlUp).Offset(1).Resize(lr - 1).Value = Application.Index(dataArr, 0, i)
    Next i
End Sub