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.
Related
I want to copy a table into a new Workbook while choosing which range I want to copy and knowing that the first Columns ("A") is automatically copied. (rows are not a problem, all of them have to be copied)
For example, i have a table composed of 28 rows and 10 columns. Added to A1:A28 (first columns, all rows),i want just to copy the column 5 and 8 with all its rows.
That's what i have until now but it doesn't work.
Sub CommandButton1_Click()
Dim newWB As Workbook, currentWB As Workbook
Dim newS As Worksheet, currentS As Worksheet
Dim CurrCols As Variant
Dim rng As rang
'Copy the data you need
Set currentWB = ThisWorkbook
Set currentS = currentWB.Sheets("Feuil1")
'select which columns you want to copy
CurrCols = InputBox("Select which column you want to copy from table (up to 10)")
If Not IsNumeric(CurrCols) Then
MsgBox "Please select a valid Numeric value !", vbCritical
End
Else
CurrCols = CLng(CurrCols)
End If
'Set rng = currentWB.currentS.Range(Cells(1, A), Cells(27, CurrCols)).Select
currentS.Range("A1:A27").Select
Selection.copy
Set rng = currentWB.currentS.Range(Cells(1, CurrCols), Cells(28, CurrCols)).Select
rng.copy
'Create a new file that will receive the data
Set newWB = Workbooks.Add
With newWB
Set newS = newWB.Sheets("Feuil1")
newS.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
End Sub
Can you help please solving it? Thanks in advance!
You can't copy a non-continuous range but you can load the data into an array and write it once to the new workbook.
Private Sub CommandButton1_Click()
Dim arData
Dim MyColumns As Range, Column As Range
Dim x As Long, y As Long
On Error Resume Next
Set MyColumns = Application.InputBox(Prompt:="Hold down [Ctrl] and click the columns to copy", Title:="Copy Columns to new Workbook", Type:=8)
On Error GoTo 0
If MyColumns Is Nothing Then Exit Sub
Set MyColumns = Union(Columns("A"), MyColumns.EntireColumn)
Set MyColumns = Intersect(MyColumns, ActiveSheet.UsedRange)
ReDim arData(1 To MyColumns.Rows.Count, 1 To 1)
For Each Column In MyColumns.Columns
y = y + 1
If y > 1 Then ReDim Preserve arData(1 To MyColumns.Rows.Count, 1 To y)
For x = 1 To Column.Rows.Count
arData(x, y) = Column.Rows(x)
Next
Next
With Workbooks.Add().Worksheets(1)
.Range("A1").Resize(UBound(arData, 1), UBound(arData, 2)) = arData
.Columns.AutoFit
End With
End Sub
try this (commented) code
Option Explicit
Sub CommandButton1_Click()
Dim newSht As Worksheet
Dim currCols As String
Dim area As Range
Dim iArea As Long
Set newSht = Workbooks.add.Worksheets("Feuil1") '<--| add a new workbook and set its "Feuil1" worksheet as 'newSht'
currCols = Replace(Application.InputBox("Select which column you want to copy from table (up to 10)", "Copy Columns", "A,B,F", , , , , 2), " ", "") '<--| get columns list
With ThisWorkbook.Worksheets("Feuil1") '<--| reference worksheet "Feuil1" in the workbook this macro resides in
For Each area In Intersect(.Range(ColumnsAddress(currCols)), .Range("A1:G28")).Areas ' loop through referenced worksheet areas of the range obtained by crossing its listed columns with its range "A1:G28"
With area '<--| reference current area
newSht.Range("A1").Offset(, iArea).Resize(.Rows.Count, .Columns.Count).value = .value '<--| copy its values in 'newSht' current column offset from "A1" cell
iArea = iArea + .Columns.Count '<--| update current column offset from 'newSht' worksheet "A1" cell
End With
Next area
End With
End Sub
Function ColumnsAddress(strng As String) As String
Dim elem As Variant
For Each elem In Split(strng, ",")
ColumnsAddress = ColumnsAddress & elem & ":" & elem & ","
Next
ColumnsAddress = Left(ColumnsAddress, Len(ColumnsAddress) - 1)
End Function
I think you can copy all column to a temp sheet and then write some code to delete the useless column. finally paste the table to your expected area.
I have a workbook with two sheets one named Datadump with headers in row 1 and site and descriptive data in columns A & B and data in column C. I would like to copy this data and paste it in the Worksheet "Factors".
This worksheet has column headers on row 2 and the same descriptive titles in columns A & B. I would like to paste the data from "Datadump" against the same row labels in "Factors" in column E.
However, "Factors" will have some rows which are not in "Datadump" so it needs to paste against relevant rows.
I have tried various code which is not working. Below is the most recent but comes up with a Runtime 1004 error on the pastespecial line.
If anyone could help that would be great.
Thanks
'VARIABLE NAME 'DEFINITION
Dim SourceSheet As Worksheet 'The data to be copied is here
Dim TargetSheet As Worksheet 'The data will be copied here
Dim ColHeaders As Range 'Column headers on Target sheet
Dim MyDataHeaders As Range 'Column headers on Source sheet
Dim DataBlock As Range 'A single column of data
Dim c As Range 'a single cell
Dim Rng As Range 'The data will be copied here (="Place holder" for the first data cell)
Dim i As Integer
Set SourceSheet = Sheets("Datadump")
Set TargetSheet = Sheets("Factors")
With TargetSheet
Set ColHeaders = .Range("A2:E2")
Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
With SourceSheet
Set MyDataHeaders = .Range("A1:C1")
For Each c In MyDataHeaders
If Application.WorksheetFunction.CountIf(ColHeaders, c.value) = 0 Then
MsgBox "Can't find a matching header name for " & c.value & vbNewLine & "Make sure the column names are the same and try again."
Exit Sub
End If
Next c
Set DataBlock = .Range(.Cells(2, 3), .Cells(.Rows.Count, 1).End(xlUp))
Set Rng = Rng.Resize(DataBlock.Rows.Count, 1)
For Each c In MyDataHeaders
i = Application.WorksheetFunction.Match(c.value, ColHeaders, 0)
Set c = DataBlock
If Not c Is Nothing Then
.Columns(c.Column).Copy
c.PasteSpecial xlPasteValues
End If
Next
Application.CutCopyMode = False
End With
End Sub
The below code will do the job,
For i = 2 To 100 'considering 100 rows in Datadump sheet
site1 = Sheets("Datadump").Cells(i, 1).Value
desc1 = Sheets("Datadump").Cells(i, 2).Value
For j = 3 To 50 'considering 50 rows in Factors sheet
site2 = Sheets("Factors").Cells(j, 1).Value
desc2 = Sheets("Factors").Cells(j, 2).Value
If site1 = site2 And desc1 = desc2 Then
Sheets("Factors").Cells(j, 5).Value = Sheets("Datadump").Cells(i, 3).Value
End If
Next j
Next i
I have a range of data on Sheet2 that links it to Sheet1 (Sheet1 is formatted and linked by Sheet2 using =if(Sheet2$x$x="","",Sheet2$x$x); this way any data put into the range C13:G62 of Sheet2 shows up in Sheet1 range C13:G62. The beginning portion on the code works to move JUST the data in the specified range to the BATCH file Sheet3 and finds the last row pasting the values from Sheet1 without copying the formulas. It was made this way so I can delete data on Sheet2 to wipe Sheet1 clean but still have all the backup data on one Sheet3.
Anyway, the problem lies when I tried to manipulate the code to copy all contents on Sheet1 (to DUPLICATE SHEET1) to another sheet at the end of the workbook:
Sheets(Sheet1).Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = _
InputBox("Name of the New WorkSheet")
This allowed me to name the sheet which was great. However by creating multiple variations of code it will not move the DATA in the RANGE to the newly created Sheet4 (there is no data). In one iteration of code I was able to get Sheet1 to copy and make Sheet4 at the end of the work book with no data in the range but have the cursor land in cell C13, the starting point for pasting just the values, and when I left click the mouse in that cell to "paste values" it would paste the values that I was trying to paste. However, either way I rearranged the code, the data would always be copied but would never paste to the Sheet4 range.
Here I have posted one variation of the code IN WHICH IT STILL WILL NOT PASTE THE VALUES TO SHEET4 (THE NEWLY CREATED SHEET) but still copies to the BATCH FILE. What am I missing here?
Dim s1Sheet As Worksheet
Dim s2Sheet As Worksheet
Dim source As String
Dim target As String
Dim rngSource As Range
Dim rngTargetStart As Range
source = "Invoice"
target = "TOTAL_INVOICE"
Application.EnableCancelKey = xlDisabled
Set s1Sheet = Sheets(source)
Set s2Sheet = Sheets(target)
Set rngSource = s1Sheet.Range("C13:G62")
Set rngTargetStart = s2Sheet.Range("C" & Rows.Count).End(xlUp).Offset(1)
'Set rngTargetFinish = ws1.Range("C" & Rows.Count).End(xlUp).Offset(1)
rngTargetStart.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value
'rngTargetFinish.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value
'Set target = Sheets("Sheet4").Range("B13:G63")
copy_non_formulas source:=rngSource, target:=rngTargetStart
' copy_non_formulas source:=Range("B13:G63"), target:=Range("B70:G109") Unhighlight
' copy_non_formulas source:=Range("B13:G63"), target:=Range("B13:G63") Unhighlight
'===Copies Sheet to End of WorkBook & Pastes Values======
Sheets(source).Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = _
InputBox("Name of the New WorkSheet")
Range("C13:G62").ClearContents
Dim rng As Range
Set rng = ActiveSheet.Range("C13:G62")
rng.ClearContents
Dim s3Sheet As Worksheet
Dim rngTargetStart2 As Range
Set s3Sheet = Sheets(Sheets.Count)
Set rngTargetStart2 = s3Sheet.Range("C" & Rows.Count).End(xlUp).Offset(1)
rngTargetStart2.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value
copy_non_formulas2 source:=rngSource, target2:=rngTargetStart2
copy_non_formulas2 source:=Range("C13:G62"), target2:=Range("C13:G62")
This is an Integrated Public Sub
copy_non_formulas(source As Range, target As Range)
Dim i As Long
Dim j As Long
Dim c As Range
For i = 1 To source.Rows.Count
For j = 1 To source.Columns.Count
Set c = source(RowIndex:=i, ColumnIndex:=j)
If Left(c.Formula, 1) <> "=" Then
target(RowIndex:=i, ColumnIndex:=j).Value = c.Value
End If
Next j
Next i
And another Public Sub for the Second Move
copy_non_formulas2(source As Range, target2 As Range)
Dim x As Long
Dim y As Long
Dim d As Range
For x = 1 To source.Rows.Count
For y = 1 To source.Columns.Count
Set d = source(RowIndex:=x, ColumnIndex:=y)
If Left(d.Formula, 1) <> "=" Then
target2(RowIndex:=x, ColumnIndex:=y).Value = d.Value
End If
Next y
Next x
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
I am trying to write a macro that will let me copy a range of data from one sheet to another sheet based on a criteria in the column before the column to be copied.
Column B is the criteria column. If there is a 1 in any row in this column then columns C thru AN will be copied from that row where there is a 1 and be pasted into another sheet starting at the top of that sheet.
I have the following code. It locates the first row that satisfies the criteria and copies this row to the second sheet, however the code does not loop thru to find other rows that satisfy the criteria. How can I adjust the code to loop and copy each instance where the criteria is satisfied?
Sub testIt()
Dim i As Integer
Application.ScreenUpdating = False
Sheets("DataDump").Activate
For i = 2 To Range("B2").End(xlDown).Row()
If Range("B" & i).Value = 1 Then
Range("C" & i, "AN" & i).Copy
Sheets("PriceData").Activate
ActiveSheet.Range("B2", "AM2").Select
ActiveSheet.Paste
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub testIt()
Dim i As Long, shtSrc As Worksheet, rngDest As Range
Application.ScreenUpdating = False
Set shtSrc = Sheets("DataDump")
Set rngDest = Sheets("PriceData").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
For i = 2 To shtSrc.Range("B2").End(xlDown).Row
If shtSrc.Range("B" & i).Value = 1 Then
shtSrc.Range("C" & i & ":AN" & i).Copy rngDest
Set rngDest = rngDest.Offset(1, 0)
End If
Next i
Application.ScreenUpdating = True
End Sub