I don't know why I am having the hardest time with this. I am just trying to copy a single row from sheet1 to the next available row on sheet2. I have to row copied but it just wont paste without giving me error. This is my copy and it is working.
ws1.Rows(j).EntireRow.Copy
Following should be helpful
Sub Demo()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow As Long, j As Long
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To 10 'change loop as required
If (your_condition) Then
lastRow = lastRow + 1
ws1.Rows(j).EntireRow.Copy ws2.Range("A" & lastRow)
End If
Next j
End Sub
Try this:
Code Sample:
Sheets("Sheet1").Cells(i, "A").EntireRow.Copy Destination:=Sheets("Sheet 2").Range("A" & Rows.Count).End(xlUp).Offset(1)
You may use the below code
Sub CopyPaste()
Sheet1.Range("A:A").Copy
Sheet2.Activate
col = 1
Do Until Sheet2.Cells(1, col) = ""
col = col + 1
Loop
Sheet2.Cells(1, col).PasteSpecial xlPasteValues
End Sub
Related
I'm trying to make a macro that will scroll through a spreadsheet an entire row at a time and merge all cells in the active row if they have data. It should do this until the last row.
The code currently sees all rows as empty and therefor skips them, I need an if condition or do until statement that will help detect and skip empty rows, detect rows with data and merge their cells and stop entirely when it reaches the last row.
My current code:
Sub merge()
Dim LastRow As Long, i As Long
Sheets("Body").Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:1").Select
For i = 1 To LastRow
If Range("A" & i).Value = "*" Then
Selection.merge = True
Selection.Offset(1).Select
Else
Selection.Offset(1).Select
End If
Next i
End Sub
I have also tried:
sub merge2()
Dim LastRow As Long, i As Long
Sheets("Body").Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Rows("1:1").Select
Do Until ActiveCell.EntireRow > LastRow
'this line below was a concept
If ActiveCell.EntireRow & ActiveCell.Column.Value = "*" Then
Selection.merge = True
Selection.Offset(1).Select
Else
Selection.Offset(1).Select
End If
Loop
End Sub
This is untested but should do what you want.
Option Explicit
Sub merge()
Dim ws As Worksheet
Dim LastRow As Integer, i As Integer
Set ws = ThisWorkbook.Sheets("Body")
ws.Activate
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
If Not IsEmpty(Range("A" & i)) And ws.Cells(i, Columns.Count).End(xlToLeft).Column > 1 Then
ws.Rows(i & ":" & i).merge
End If
Next i
End Sub
This If will test for a) whether the cell in column A is empty and b) whether there are any other cells in that row. if statement a evaluates to false AND statement b is greater than 1 it will execute the If statement
#Tom I've taken your code and added in an error handler that makes it work without fault, thank you very much for your patience, you've been a fantastic help.
Sub merge2()
Dim ws As Worksheet
Dim LastRow As Integer, i As Integer
Set ws = ThisWorkbook.Sheets("Body")
ws.Activate
With ws
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
If Not IsEmpty(Range("A" & i)) And ws.Cells(i, Columns.Count).End(xlToLeft).Column >= 1 Then
On Error Resume Next
ws.Rows(i & ":" & i).merge = True
End If
Next i
End Sub
Since hours now I'm struggling with the same problem now...
I try to copy certain rows upon a condition in column A to an other Workbook. I don't get an error message, the code runs through, but nothing happens. Somehow it seems not to "see" the lines between Then and End If. If I run the code manually, the line directly jumps to End if and further repeats the loop.
Do you have any idea what could be wrong? - Thanks for any help!
This part of my code lookes like:
Dim LastRow As Integer, i As Integer
LastRow = Workbooks("Workb1.xlsx").Sheets("Sheet1").Cells(Rows.Count,"A").End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2).Value = "848" Then
Range(Cells(i, 2), Cells(i, 14)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Paste
End If
Next i
After your first comments, the edited code now is:
Dim LastRow As Integer, i As Integer
Dim ws4 As Worksheet
Set ws4 = Workbooks("Workb1").Sheets("Sheet1")
LastRow = ws4.Cells(Rows.Count, "A").End(xlUp).Row
With ws4
For i = 1 To LastRow
If .Cells(i, 1).Value = 848 Then
Range(.Cells(i, 1)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Paste
End If
Next i
End With
Ok, What I actually want to do:
Always copy from source to target sheet
First only for rows, which have a 848 in column A and paste them to target. So for all those rows, which have an 848 in column A:
Copy value in the column X in “source” --> Column Y in “target”
A --> A N-->B O-->C AM -->D AH -->G P-->I E-->J F-->K
Now, only consider those cells with a 618 in column A and copy/paste, again to the firs empty cell in this column (so after the rows with 848, now the target-sheet gets completed with the 618 cells.
A --> A N-->B O-->C AM -->D T -->G P-->I E-->J F-->K
Column E and F in the target: there are formula, which have to be elongated to the end of the column
I did change that much until now, that it's not even a working code anymore...
Private Sub CommandButton1_Click()
Dim LastRow As Integer, i As Integer, erow As Integer, LastRow2 As Integer
Dim ws4 As Worksheet
Set ws4 = Workbooks("macro_source").Sheets("Sheet1")
LastRow = ws4.Cells(Rows.Count, "A").End(xlUp).Row
With ws4
For i = 2 To LastRow
If .Cells(i, 1).Value = 848 Then
Workbooks("macro_source").Sheets("Sheet1").Activate
.Cells(i, 1).Copy
Set erow = Workbooks("destination.xlsx").Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i
End With
End Sub
Maybe I have to add, that both files are pre-edited by the prior code, which I did not show here. And I still did not find out whether it's possible to upload the data as excel files...
Many thanks for your help again, I really stuck...
copying between books seems to go wrong fairly often even when what you have coded seems to logically be correct.
I have found in the past it's better to reference the sheet then use the reference and to use the with statement as it seems to handle range selections better
Some code below should work for you... (I have altered the paste to start at A1 and increment each time as the original code would overwrite each time it found a value - you should be able to edit to paste where you want)
Sub CopyToNewBook()
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = Workbooks("Workb1.xlsx")
Dim wbDest As Workbook: Set wbDest = Workbooks("destination.xlsx")
If wbSrc Is Nothing Or wbDest Is Nothing Then
MsgBox "Please open both workbooks required"
Exit Sub
End If
On Error GoTo 0
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Sheets("Sheet1")
Dim wsDest As Worksheet: Set wsDest = wbDest.Sheets("Sheet1")
Dim LastRow As Long, i As Long, j As Long: j = 63976
With wsSrc
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 2 To LastRow
If .Cells(i, 1).Value = "848" Then
.Range(.Cells(i, 2), .Cells(i, 14)).Copy
wsDest.Range("A" & j).PasteSpecial xlPasteValues
j = j + 1
End If
Next i
End With
End Sub
UPDATE
For searching against multiple values
Sub CopyToNewBook()
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = Workbooks("Workb1.xlsx")
Dim wbDest As Workbook: Set wbDest = Workbooks("destination.xlsx")
If wbSrc Is Nothing Or wbDest Is Nothing Then
MsgBox "Please open both workbooks required"
Exit Sub
End If
On Error GoTo 0
Dim SearchValues() As String: SearchValues = Split("848,618", ",")
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Sheets("Sheet1")
Dim wsDest As Worksheet: Set wsDest = wbDest.Sheets("Sheet1")
Dim LastRow As Long, i As Long, j As Long, z As Long: z = 63976
With wsSrc
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For j = 0 To UBound(SearchValues)
For i = 2 To LastRow
If .Cells(i, 1).Value = SearchValues(j) Then
.Range(.Cells(i, 2), .Cells(i, 14)).Copy
wsDest.Range("A" & z).PasteSpecial xlPasteValues
z = z + 1
End If
Next i
Next j
End With
End Sub
To add to my comment
you're also counting the number of rows in column A and running the loop on column B. I'd also set your cells as it could be looking at the wrong sheet
Dim LastRow As Integer, i As Integer
Dim ws as worksheet
set ws = Workbooks("Workb1.xlsx").Sheets("Sheet1")
LastRow = ws.Cells(Rows.Count,"B").End(xlUp).Row
with ws
For i = 2 To LastRow
If .Cells(i, 2).Value = 848 Then
Range(.Cells(i, 2), .Cells(i, 14)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Paste
End If
Next i
end with
Update:
you could simplify a lot of this
Dim LastRow As Integer, i As Integer
Dim ws as worksheet
set ws = Workbooks("Workb1.xlsx").Sheets("Sheet1")
LastRow = ws.Cells(Rows.Count,"B").End(xlUp).Row
with ws
For i = 2 To LastRow
If Trim(Val(.Cells(i, 1))) = 848 Then
Range(.Cells(i, 2)).Copy _
destination:=Workbooks("destination.xlsx") _
.Worksheets("Sheet1").Range("A63976").Paste
End If
Next i
end with
This code will work fine. Check your cell that has 848 in it manually and make sure it is an integer.
Try this:
Dim LastRow As Integer, i As Integer
Dim ws4 As Worksheet
Set ws4 = Workbooks("Workb1.xlsx").Sheets("Sheet1")
LastRow = ws4.Cells(Rows.Count, "A").End(xlUp).Row
With ws4.Columns(1)
For i = 1 To LastRow
If .Cells(i).Value = 848 Then
Range(.Cells(i, 2), .Cells(i, 14)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Select
Selection.PasteSpecial
End If
Next i
End With
EDIT:
Ok, I'm sure this is frowned upon, but this is how I would have solved the issue. It's nothing close to pro-code, but it gets the work done.
Range("A1").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value = 848 Then
Range(ActiveCell.Offset(0, 1).Address(False, False), ActiveCell.Offset(0, 14).Address(False, False)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Select
Selection.PasteSpecial
End If
ActiveCell.Offset(1, 0).Select
Loop
If this code does not work, there's something else that's fishy. The code needs to be executed in the worksheet containing the list, which should be placed in column A and contain no blanks.
You can always change which sheet is selected by adding code.
I want a code that doing the following:
if the last 5 characters of the text value in the cell in column E is “(UK)” then the macro copies the range consisting of 4 cells in columns B,C,D,E in the same row and pastes below the last non-empty row in the worksheet “Sheet 1” in the same columns (so all ranges B-E with “(UK)” must be transferred to the sheet “Sheet1”);
I am just posting my code. Hope #Jonathan will learn it.
Sub CopyC()
Dim wb As Workbook
Dim ws As Worksheet
Dim sheet1lastrow As Long
Dim lastrow As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets("sheet1")
lastrow = ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row
sheet1lastrow = ws.Range("E" & Rows.Count).End(xlUp).Row
For i = 1 To lastrow
If Right(ActiveSheet.Cells(i, 5).Value, 5) = "(UK)" Then
ActiveSheet.Range(Cells(i, 2), Cells(i, 5)).Copy
ws.Cells(sheet1lastrow + 1, 2).PasteSpecial xlValues
Application.CutCopyMode = False
Application.CutCopyMode = True
End If
Next
End Sub
I am writing a macro that copies a value from one excel worksheet, and pastes it into another. As seen below, I have a code that correctly copies and pastes my value into the correct worksheet, but I want it to paste into the next empty cell in row 3, instead of just cell "C3". All help is appreciated.
Private Sub CommandButton1_Click()
Dim wsMaster As Worksheet, wbDATA As Workbook
Dim NextRow As Long, LastRow As Long
Dim vMax As Variant
Set wsMaster = ThisWorkbook.Sheets("Contract Metrics")
NextRow = wsMaster.Range("A" & Rows.Count).End(xlUp).Row + 1
Set wbDATA = Workbooks.Open("C:\Documents and Settings\Michael Palkovitz\My Documents\Test\Contracts Metrics.xlsx")
With wbDATA.Sheets("Contract Task Summary(1)")
LastRow = .Range("C" & .Rows.Count).End(xlUp).Row
If LastRow > 1 Then
.Range("C" & LastRow).Copy
wsMaster.Range("C" & 3).PasteSpecial xlPasteValues
wsMaster.Range("C" & 3).PasteSpecial xlPasteFormats
End If
End With
wbDATA.Close False
End Sub
This is the code you are looking for:
Private Sub CommandButton1_Click()
Dim wsMaster As Worksheet, wbDATA As Workbook
Dim NextRow As Long, LastRow As Long
Dim vMax As Variant
Dim columnToPaste As Integer
Dim lastColumnToPaste As Integer
Dim lastColumn as Integer
Set wsMaster = ThisWorkbook.Sheets("Contract Metrics")
NextRow = wsMaster.Range("A" & Rows.Count).End(xlUp).Row + 1
Set wbDATA = Workbooks.Open("C:\Documents and Settings\Michael Palkovitz\My Documents\Test\Contracts Metrics.xlsx")
With wbDATA.Sheets("Contract Task Summary(1)")
LastRow = .Range("C" & .Rows.Count).End(xlUp).Row
If LastRow > 1 Then
.Range("C" & LastRow).Copy
lastColumn = 3
lastColumnToPaste = lastColumn + 20
columnToPaste = lastColumn - 1
Do
columnToPaste = columnToPaste + 1
If IsEmpty(wsMaster.Cells(lastRow, columnToPaste)) Then
wsMaster.Cells(lastRow, columnToPaste).PasteSpecial xlPasteValues
wsMaster.Cells(lastRow, columnToPaste).PasteSpecial xlPasteFormats
Exit Do
End If
Loop While (columnToPaste < lastColumnToPaste)
End If
End With
wbDATA.Close False
End Sub
This is just a basic approach to how the problem should be solved. You should update some values dynamically (e.g., maximum row to check, given by the variable lastRowToPaste).
Note that writing/pasting between two different workbooks is very inefficient. In case of having to repeat this process for a long enough time, I would: open the input spreadsheet and store all the values in a temporary location (depending upon the size, in an array or in a temporary file), close it; open the destination spreadsheet and write the data from this location (without relying on copy/paste). This is a much faster approach to the problem.
I have an Excel sheet with names as one column and their working hours as values in next column.
I want to copy names with values greater than 40 to new sheet without any blanks in columns. The new sheet should have both names and the working hours; any text in the values column should be ignored.
Sub CopyCells()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row
For i = 1 To lastrow1
If sh1.Cells(i, "F").Value > 20 Then
sh2.Range("A" & i).Value = sh1.Cells(i, "F").Value
End If
Next i
End Sub
I would recommend using AutoFilter to copy and paste as it is faster than looping. See the example below.
My Assumptions
Original Data is in Sheet 1 as shown the snapshot below
You want the output in Sheet 2 as shown the snapshot below
CODE
I have commented the code so that you will not have a problem understanding it.
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow As Long
'~~> Set the input sheet
Set wsI = Sheets("Sheet1"): Set wsO = Sheets("Sheet2")
'~~> Clear Sheet 2 for output
wsO.Cells.ClearContents
With wsI
'~~> Remove any existing filter
.AutoFilterMode = False
'~~> Find last row in Sheet1
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Filter Col B for values > 40
With .Range("A1:B" & lRow)
.AutoFilter Field:=2, Criteria1:=">40"
'~~> Copy the filtered range to Sheet2
.SpecialCells(xlCellTypeVisible).Copy wsO.Range("A1")
End With
'~~> Remove any existing filter
.AutoFilterMode = False
End With
'~~> Inform user
MsgBox "Done"
End Sub
SNAPSHOT
Try rhis
Sub CopyCells()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim j As Long, i As Long, lastrow1 As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
lastrow1 = sh1.Cells(Rows.Count, "F").End(xlUp).Row
j = 1
For i = 1 To lastrow1
If Val(sh1.Cells(i, "F").Value) > 20 Then
sh2.Range("A" & j).Value = sh1.Cells(i, "F").Value
j = j + 1
End If
Next i
End Sub