Copying Multiple columns in Excel-Vba - vba

Hi I am trying to copy multiple columns from one workbook to another, and below is the code how I copied one and need help in making the code more optimized as I don't want to write same code for all the columns. below is the code.
Sub Copymc()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("H:\testing\demo\test2.xlsx")
Set y = Workbooks.Open("H:\testing\demo\test1.xlsx")
Dim LastRow As Long
Dim NextRow As Long
' determine where the data ends on Column B Sheet1
x.Worksheets("Sheet1").Activate
Range("A65536").Select
ActiveCell.End(xlUp).Select
LastRow = ActiveCell.Row
' copy the data from Column B in Sheet 1
Range("A2:A" & LastRow).Copy
' Determine where to add the new data in Column C Sheet 2
y.Worksheets("Sheet1").Activate
Range("A65536").Select
ActiveCell.End(xlUp).Offset(1, 0).Select
NextRow = ActiveCell.Row
' paste the data to Column C Sheet 2
y.Worksheets("Sheet1").Range("A" & NextRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
End Sub
I tried to put all columns in range statement but problem I found was how to paste? How can I do it for multiple columns without repeating the code? Thanks in advance.

Let's say you want to copy columns A-D:
Sub Copymc()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("H:\testing\demo\test2.xlsx")
Set y = Workbooks.Open("H:\testing\demo\test1.xlsx")
Dim LastRow As Long
Dim NextRow As Long
' determine where the data ends on Column B Sheet1
x.Worksheets("Sheet1").Activate
Range("A65536").Select
ActiveCell.End(xlUp).Select
LastRow = ActiveCell.Row
' copy the data from Column B in Sheet 1
Range("A2:D" & LastRow).Copy y.worksheets("Sheet1").range("a65536").end(xlup).offset(1,0)
' Determine where to add the new data in Column C Sheet 2
'y.Worksheets("Sheet1").Activate
'Range("A65536").Select
'ActiveCell.End(xlUp).Offset(1, 0).Select
'NextRow = ActiveCell.Row
' paste the data to Column C Sheet 2
'y.Worksheets("Sheet1").Range("A" & NextRow).Select
'ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
End Sub

I try to avoid the copy and paste functions as much as possible. To get around this I would loop through all of the values in the column and move them to your other workbook as such:
Sub test()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("H:\testing\demo\test2.xlsx")
Set y = Workbooks.Open("H:\testing\demo\test1.xlsx")
Dim LastRow As Long
LastRow = x.Sheets("Sheet1").Range("A65536").End(xlUp).Row
For i = 1 To LastRow
CopyVal = x.Sheets("Sheet1").Range("A1").Offset(i, 0).Value
CopyVal2 = x.Sheets("Sheet1").Range("A1").Offset(i, 1).Value
CopyVal3 = x.Sheets("Sheet1").Range("A1").Offset(i, 2).Value
CopyVal4 = x.Sheets("Sheet1").Range("A1").Offset(i, 3).Value
y.Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 3).Value = CopyVal4
y.Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 2).Value = CopyVal3
y.Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 1).Value = CopyVal2
y.Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 0).Value = CopyVal
Next
End Sub

Related

VBA: How can i select the cell in a row which matches a variable's value?

I have 2 sheets. Sheet1 has 2 rows: column names and values.
Sheet 2 is a master sheet with all the possible column names in. I need to copy the values from sheet 1 into their appropriate column.
I think i can do this via a match function, and so far i have this:
Sub dynamic_paste()
Dim Columnname As String
Dim inputvalue As String
Dim starter As Integer
Dim i As Integer
starter = 0
For i = 1 To 4
'replace 4 with rangeused.rows.count?
Sheets("sheet1").Select
Range("a1").Select
ActiveCell.Offset(0, starter).Select
Columnname = ActiveCell
'sets columnname variable
ActiveCell.Offset(1, 0).Select
inputvalue = ActiveCell
'sets inputname variable
Sheets("sheet2").Select
'**Cells(0, WorksheetFunction.Match(Columnname, Rows(1), 0)).Select**
Range("a1").Offset(1, starter).Value = inputvalue
'inputs variable in the next cell along
starter = starter + 1
Next
End Sub
I need to find out how to use my columnname variable as the matching value, and then offset down to the first row that is empty - then change the value of that cell to the variable called inputvalue.
For extra points: I need to make sure the code doesnt break if they dont find a matching value, and if possible put any values that dont match into the end of the row?
What about this:
Dim LR As Long, X As Long, LC As Long, COL As Long
Dim RNG As Range, CL As Range
Option Explicit
Sub Test()
LR = Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row 'Get last used row in your sheet
LC = Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column 'Get last used column in your sheet
Set RNG = Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, LC))
'Loop through all the columns on your sheet with values
For X = 1 To Sheets(1).Cells(1, Sheets(1).Columns.Count).End(xlToLeft).Column
Set CL = RNG.Find(Sheets(1).Cells(1, X).Value, lookat:=xlWhole)
If Not CL Is Nothing Then
COL = CL.Column
Sheets(2).Cells(LR + 1, COL).Value = Sheets(1).Cells(2, X).Value 'Get the value on LR offset by 1
Else
Sheets(2).Cells(1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(1, X).Value
Sheets(2).Cells(LR + 1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(2, X).Value
End If
Next X
End Sub
This way you will avoid using select. Which is very recommandable!
This is Sheet1:
This is Sheet2:
This is the code:
Option Explicit
Sub DynamicPaste()
Dim col As Long
Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
For col = 1 To 3
Dim currentRow As Long
currentRow = WorksheetFunction.Match(wks2.Cells(1, col), wks1.Columns(1))
wks2.Cells(2, col) = wks1.Cells(currentRow, 2)
Next col
End Sub
This is Sheet2 after the code:
This is a must-read - How to avoid using Select in Excel VBA

How can I use LastRow on a range function?

So I want to copy values from a certain range of cells from worksheet 1-workbook A to worksheet 1- workbook B .
I want to copy everything from the source worksheet: more specifically, every cell that has a value on it.
On the destination worksheet, there are specified cells for the values on source worksheet.
this is my code so far (it's bad, but i'm a noob at VBA!) :
Sub CopyRangeofCells()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("C:\test\template.xlsx")
Set y = Workbooks.Open("C:\test\finalfile.xlsx")
x.Sheets("RDBMergeSheet").Range("A1").Copy
y.Sheets("CW Fast").Range("A1").PasteSpecial
'Close x:
x.Close
End Sub
On my range, I want to do something like Range("A1:LastRow") or anything of the sort. How do I do it? Can I create a lastrow variable and then do ("A1:mylastrowvariable") ??
Hope you can help! VBA is so confusing to me, give me Java all day long! :P
Let's do it step-by-step:
Sub CopyRangeofCells()
Dim x As Workbook
Dim y As Workbook
Dim LastRow As Long
Set x = Workbooks.Open("C:\test\template.xlsx")
Set y = Workbooks.Open("C:\test\finalfile.xlsx")
With x.Sheets("RDBMergeSheet")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column "A"
.Range("A1:A" & LastRow).Copy
End With
y.Sheets("CW Fast").Range("A1").PasteSpecial xlPasteValues
'Close x:
x.Close
End Sub
Something like this:
Sub CopyRangeofCells()
Dim x As Workbook
Dim y As Workbook
Dim LastRow as Long
Dim LastRowToCopy as Long
Set x = Workbooks.Open("C:\test\template.xlsx")
Set y = Workbooks.Open("C:\test\finalfile.xlsx")
LastRowToCopy = x.Sheets("RDBMergeSheet").Cells(x.Sheets("RDBMergeSheet").Rows.Count, "A").End(xlUp).Row
x.Sheets("RDBMergeSheet").Range("A1:A" & LastRowToCopy).Copy
'copy from A1 to lastrow
LastRow = y.Sheets("CW Fast").Cells(y.Sheets("CW Fast").Rows.Count, "A").End(xlUp).Row + 1 'find the last row
y.Sheets("CW Fast").Range("A" & LastRow).PasteSpecial xlPasteValues
'paste on the lastrow of destination + 1 (so next empty row)
x.Close
End Sub

Excel vba copying and pasting based on cell value code not working

So im pretty new to VBA coding, and I'm trying to setup a commandbutton that when activated copys everything from sheet "Opties" to the sheet "BOM" from the column D and F that has a 1 in column with the titel "Totaal" and remove blanks.
So far this is my code
Sub Copy()
Dim c As Integer
Dim x As Integer
Dim y As Integer
Dim ws1 As Worksheet: Set ws1 = Sheets("Optie")
Dim ws2 As Worksheet: Set ws2 = Sheets("BOM")
Dim colNum As Integer
colNum = Worksheetfuntion.Match("Totaal", ws1.Range("A1:ZZ1"), 0)
c = 1
x = -4 + colNum
y = -6 + colNum
Set rng1 = ws1.Column(colNum)
Set rng2 = ws2.Range("C5:C25000")
For Each c In ws1.rng1
rng1.Offset(0, x).Copy
rng2.Offset(0, 1).PasteSpecial xlPasteValues
rng1.Offset(0, y).Copy
rng2.Offset(0, 2).PasteSpecial xlPasteValues
Next c
End Sub
I think the following code should work:
'Try to avoid using names that Excel uses - you will sometimes "block" the
'native function, so call the subroutine "myCopy" or something else, but
'preferably not "Copy"
Sub myCopy()
Dim r1 As Long ' Use Long rather than Integer, because Excel
Dim r2 As Long ' now allows for more than 65536 rows
'Use Worksheets collection for worksheets, and only use the Sheets
' collection if you need to process Charts as well as Worksheets
Dim ws1 As Worksheet: Set ws1 = Worksheets("Optie") 'Should this be "Opties"?
Dim ws2 As Worksheet: Set ws2 = Worksheets("BOM")
Dim colNum As Long
colNum = WorksheetFunction.Match("Totaal", ws1.Range("A1:ZZ1"), 0)
r2 = 5 ' I guessed that 5 is the first row you want to write to
'Loop through every row until the last non-empty row in Totaal column
For r1 = 1 To ws1.Cells(ws1.Rows.Count, colNum).End(xlUp).Row
'See if value in Totaal column is 1
If ws1.Cells(r1, colNum).Value = 1 Then
'I have guessed that your destination columns are D & E based on
'your Offset(0, 1) and Offset(0, 2) from column C
'I have guessed that your source columns are F & D based on the
'question mentioning those columns, and the offsets of -4 and -6
'in your current code - I assume based on "Totaal" being column J
'Change my guesses as necessary
'Copy values to destination from source
ws2.Cells(r2, "D").Value = ws1.Cells(r1, "F").Value
ws2.Cells(r2, "E").Value = ws1.Cells(r1, "D").Value
'Increment row counter for destination sheet
r2 = r2 + 1
End If
Next
End Sub

Copy and Paste dynamic ranges to new sheet in Excel with VBA

I am new to macro writing and I need some help.
I have one sheet and need to copy the columns and reorder them to paste into a software program.
I want to copy A2 - the last data entry in column A and paste it into A1 on Sheet2
I want to copy B2 - the last data entry in column A and paste it into K1 on Sheet2
I want to copy C2 - the last data entry in column A and paste it into C1 on Sheet2
I want to copy D2 - the last data entry in column A and paste it into D1 on Sheet2
Then from Sheet 2, I want to copy A1:KXXXX (to the last entry in column A) and save it on the clipboard to paste into the other application
Here is my code, I have tried... (I know this is just for copying column A, but I got stuck there.)
Sub Copy()
aLastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("A2" & aLastRow).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
End Sub
Thank you so much for your help!
Jess
Try this instead. Given that you said you got an error with the paste code and I am still using that, I think you'll still have an error there. Post the error message. Hopefully we can figure that out.
Sub copyStuff()
Dim wsIn As Worksheet
Set wsIn = Application.Worksheets("Sheet1")
Dim endRow As Long
wsIn.Activate
endRow = wsIn.Cells(wsIn.Rows.Count, "A").End(xlUp).Row
Dim r As Range
Dim wsOut As Worksheet
Set wsOut = Application.Worksheets("Sheet2")
' column a to column a
Set r = wsIn.Range(Cells(2, 1), Cells(endRow, 1))
r.Copy
wsOut.Range("A1").PasteSpecial xlPasteAll
' column b to column k
Set r = wsIn.Range(Cells(2, 2), Cells(endRow, 2))
r.Copy
wsOut.Range("K1").PasteSpecial xlPasteAll
' column c to column c
Set r = wsIn.Range(Cells(2, 3), Cells(endRow, 3))
r.Copy
wsOut.Range("C1").PasteSpecial xlPasteAll
' column d to column d
Set r = wsIn.Range(Cells(2, 4), Cells(endRow, 4))
r.Copy
wsOut.Range("D1").PasteSpecial xlPasteAll
' Copy data from sheet 2 into clipboard
wsOut.Activate
Set r = wsOut.Range(Cells(1, 1), Cells(endRow - 1, 11))
r.Copy
End Sub
My original answer is below here. You can disregard.
This should accomplish your first goal:
Sub copyStuff()
Dim wsIn As Worksheet
Set wsIn = Application.Worksheets("Sheet1")
Dim endRow As Long
endRow = wsIn.Cells(wsIn.Rows.Count, "A").End(xlUp).Row
Dim r As range
Set r = wsIn.range(Cells(2, 1), Cells(endRow, 4))
r.Copy
Dim wsOut As Worksheet
Set wsOut = Application.Worksheets("Sheet2")
wsOut.range("A1").PasteSpecial xlPasteAll
End Sub
I copied all 4 columns at once since that would be much faster but it assumes the columns are the same length. If that isn't true you would need to copy one at a time.
The data should be in the clipboard at the end of the macro.
Edit: I removed "wsIn.Activate" since it isn't really needed.
Edit 2: Oops! I just noticed you wanted the output in different columns. I'll work on it.
Generally you want to avoid .Select and .Paste when copying values and rather copy by .value = .value:
Sub Copy()
Dim aLastRow As Long
Dim clipboard As MSForms.DataObject
Set clipboard = New MSForms.DataObject
aLastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Sheet2").Range("A1:A" & aLastRow - 1).Value = Sheets("Sheet1").Range("A2:A" & aLastRow).Value
Sheets("Sheet2").Range("K1:K" & aLastRow - 1).Value = Sheets("Sheet1").Range("B2:B" & aLastRow).Value
Sheets("Sheet2").Range("C1:D" & aLastRow - 1).Value = Sheets("Sheet1").Range("C2:D" & aLastRow).Value
clipboard.SetText Sheets("Sheet2").Range("A1:K" & aLastRow - 1).Value
clipboard.PutInClipboard
End Sub

Excel Copy whole row from a sheet to another sheet based on one column value

I need to copy an entire row from a sheet and paste in another sheet with same header consider a particular column value is equal to 89581.But my VBA throws 424 error.Please help.
Sub CopyData()
Dim c As Range
Dim Row As Long
Dim sheetUse As Worksheet
Dim sheetCopy As Worksheet
Set sheetUse = Sheets("Data1").Select
Set sheetCopy = Sheets("Data2").Select
Row = 3 'Assume same header in sheet2 as in sheet1
For Each c In sheetUse.Range("O3", Sheet1.Range("O65536").End(xlUp))
If c = 89581 Then
'copy this row to sheet2
Row = Row + 1
c.EntireRow.Copy sheetCopy.Cells(Row, 1)
End If
Next c
Application.CutCopyMode = False
End Sub
Here you go, build a reference to copy then copy and paste in one go.
Sub CopyToOtherSheet()
Dim sheetUse As Worksheet, sheetCopy As Worksheet, i As Long, CopyRange As String
Set sheetUse = Sheets("Data1")
Set sheetCopy = Sheets("Data2")
For i = 3 To sheetUse.Cells(Rows.Count, 15).End(xlUp).Row
If sheetUse.Cells(i, 15) = 89581 Then CopyRange = CopyRange & "," & i & ":" & i
Next i
sheetUse.Range(Right(CopyRange, Len(CopyRange) - 1)).Copy
sheetCopy.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll 'Change to values or formats or whatever you want
Application.CutCopyMode = False
End Sub
Assumed Data1 is the sheet with the data in and Data2 is the one to copy to.