I have a table with certain rows with "striked-out" font. The objective is to cut these rows and paste them into another sheet.
So far, I have the following code, and is not working (EDIT: a new sheet gets created but nothing is cut nor pasted):
Sub test()
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets.Add After:=ActiveSheet
For i = 2 To lrow
If Cells(i, 1).Font.Strikethrough = True Then
Cells(i, 1).EntireRow.Cut
Sheets(ActiveSheet.Index + 1).Paste
End If
Next i
End Sub
How would I fix this?
More like this:
Sub test()
Dim i As Long, lrow As Long, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Long
Set wsSrc = ActiveSheet 'or something more specific
lrow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
'get a reference to the sheet when adding it
Set wsDest = wsSrc.Parent.Sheets.Add(After:=ActiveSheet)
destRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
For i = 2 To lrow
If wsSrc.Cells(i, 1).Font.Strikethrough = True Then
wsSrc.Rows(i).Cut wsDest.Cells(destRow, 1)
destRow = destRow + 1 'next paste row
End If
Next i
End Sub
Related
I have the same code in the same workbook and in a separate sheet and it was working perfectly alright. I copied the same code for the same workbook but different sheet and there goes an error.
Sub ExecuteLkup()
Dim LastRow As Long
Dim LastCol As Long
Dim iRow As Long
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:="V:\Mar22\Top Segments & Top All_Mar22.xlsx")
Set ws = Sheet4
Range("K2").Value = WorksheetFunction.Vlookup(Range("F").Value, wb.Sheets("TopAll").Range("E:I"), 5, 0)
With ws
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Cells(1, LastCol + 1).Value = "Variance"
End With
Range("L2").Select
ActiveCell.FormulaR1C1 = "=[#[BRN_nett_grand_total]]-[#Column1]"
End Sub
I have two ranges on two sheets.
I am trying to compare these two lists for differences, and copy any differences from Sheet2 to Sheet1. Here is my code. I think it's close, but something is off, because all if does is delete row 14 on Sheet1 and no different cells from Sheet2 are copied to Sheet1. What's wrong here?
Sub Compare()
Dim lastRow1 As Integer
Dim lastRow2 As Integer
Dim foundTrue As Boolean
lastRow1 = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
lastRow2 = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "E").End(xlUp).Row
For i = 2 To lastRow2
foundTrue = False
For j = 2 To lastRow1
If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then
foundTrue = True
Exit For
End If
Next j
If Not foundTrue Then
Sheets("Sheet2").Cells(i).Copy Destination:=Sheets("Sheet1").Rows(lastRow1 - 1)
End If
Next i
Debug.Print i
End Sub
I want to end up with this.
Nothing that a debug session can't reveal.
You need to copy to lastrow + 1, not lastrow - 1.
After copying the first value, you need to somehow increase the value for lastRow1. But as you use this value as limit in your (inner) for-loop, you shouldn't modify it. So I suggest you introduce a counter variable that counts how many rows you already copied and use this as offset.
And you have some more mistakes:
Your data in sheet2 is in columns E and F, but you compare the values of column "A" (you wrote Sheets("Sheet2").Cells(i, 1).Value)
The source in your copy-command accesses is .Cells(i). In case i is 10, this would be the 10th cell of your sheet, that is J1 - not the cell E10. And even if it was the correct cell, you would copy only one cell, not two.
Obgligatory extra hints: Use Option Explicit (your variables i and j are not declared), and always use Long, not Integer.
Code could look like (I renamed foundTrue because it hurts my eyes to see True in a variable name)
Dim i As Long, j As Long
For i = 2 To lastRow2
foundValue = False
For j = 2 To lastRow1
If Sheets("Sheet2").Cells(i, 5).Value = Sheets("Sheet1").Cells(j, 1).Value Then
foundValue = True
Exit For
End If
Next j
If Not foundValue Then
addedRows = addedRows + 1
Sheets("Sheet2").Cells(i, 5).Resize(1, 2).Copy Destination:=Sheets("Sheet1").Cells(lastRow1, 1).Offset(addedRows)
End If
Next i
But this leaves a lot room for improvement. I suggest you have a look to the following, in my eyes it's much cleaner and much more easy to adapt. There is still room for optimization (for example read the data into arrays to speed up execution), but that's a different story.
Sub Compare()
Const sourceCol = "E"
Const destCol = "A"
Const colCount = 2
' Set worksheets
Dim sourceWs As Worksheet, destWs As Worksheet
Set sourceWs = ThisWorkbook.Sheets("Sheet2")
Set destWs = ThisWorkbook.Sheets("Sheet1")
' Count rows
Dim lastRowSource As Long, lastRowDest As Long
lastRowSource = sourceWs.Cells(sourceWs.Rows.Count, sourceCol).End(xlUp).Row
lastRowDest = destWs.Cells(destWs.Rows.Count, destCol).End(xlUp).Row
Dim sourceRow As Long, destRow As Long
Dim addedRows As Long
For sourceRow = 2 To lastRowSource
Dim foundValue As Boolean
foundValue = False
For destRow = 2 To lastRowDest
If sourceWs.Cells(sourceRow, sourceCol).Value = destWs.Cells(destRow, destCol).Value Then
foundValue = True
Exit For
End If
Next destRow
If Not foundValue Then
addedRows = addedRows + 1
sourceWs.Cells(sourceRow, sourceCol).Resize(1, colCount).Copy Destination:=destWs.Cells(lastRowDest, 1).Offset(addedRows)
End If
Next sourceRow
End Sub
Copy Differences (Loop)
A Quick Fix
Option Explicit
Sub Compare()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws1 As Worksheet: Set ws1 = wb.Worksheets("Sheet1")
Dim lRow1 As Long: lRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
Dim fRow1 As Long: fRow1 = lRow1
Dim ws2 As Worksheet: Set ws2 = wb.Worksheets("Sheet2")
Dim lRow2 As Long: lRow2 = ws2.Cells(ws2.Rows.Count, "E").End(xlUp).Row
Dim i As Long, j As Long
For i = 2 To lRow2
For j = 2 To lRow1
If ws2.Cells(i, "E").Value = ws1.Cells(j, "A").Value Then Exit For
Next j
' Note this possibility utilizing the behavior of the For...Next loop.
' No boolean necessary.
If j > lRow1 Then ' not found
fRow1 = fRow1 + 1
ws2.Cells(i, "E").Resize(, 2).Copy ws1.Cells(fRow1, "A")
End If
Next i
MsgBox "Found " & fRow1 - lRow1 & " differences.", vbInformation
End Sub
I need to loop through a column and if a conditions if met copy cell from one sheet to another.
I'm finding problems with the incremental..
In this case double the results.
Thank you in advance.
KR
Sub copycell()
Dim iLastRow As Long
Dim i As Long
Dim erow As Long
erow = 1
iLastRow = Worksheets("Clientes").Cells(Rows.Count, "C").End(xlUp).Row
For i = 13 To iLastRow
If Sheets("Clientes").Cells(i, 3) = "0" Then
Worksheets("Ficheros").Range("B" & erow).End(xlUp).Offset(1) = Sheets("Clientes").Cells(i, 4)
erow = erow + 1
End If
Next i
End Sub
Why not use Autofilter to filter the column C and if the autofilter returns any rows, copy them to the destination sheet?
See if something like this works for you...
Sub CopyCells()
Dim wsData As Worksheet, WsDest As Worksheet
Dim iLastRow As Long
Application.ScreenUpdating = False
Set wsData = Worksheets("Clientes")
Set WsDest = Worksheets("Ficheros")
iLastRow = wsData.Cells(Rows.Count, "C").End(xlUp).Row
wsData.AutoFilterMode = False
With wsData.Rows(12)
.AutoFilter field:=3, Criteria1:="0"
If wsData.Range("D12:D" & iLastRow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
wsData.Range("D13:D" & iLastRow).SpecialCells(xlCellTypeVisible).Copy
WsDest.Range("B" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
End If
End With
wsData.AutoFilterMode = False
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
You can achieve your result with AutoFilter, but my answer is trying to resolve your code using the For loop.
Modified Code
Option Explicit
Sub copycell()
Dim iLastRow As Long
Dim i As Long
Dim erow As Long
' get first empty row in column B in "Ficheros" sheet
erow = Worksheets("Ficheros").Range("B" & Rows.Count).End(xlUp).Row + 1
With Worksheets("Clientes")
iLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 13 To iLastRow
If .Cells(i, 3) = "0" Then
Worksheets("Ficheros").Range("B" & erow) = .Cells(i, 4)
erow = erow + 1
End If
Next i
End With
End Sub
With the code I am currently using it will paste the information from Worksheet 1 to worksheet 2 in the Top line of worksheet2. What I want next is to use the same code but for different cell values and to copy the information from worksheet 1 to worksheet 2 but in the next available line in worksheet 2.
I have been researching about excel macros and vba for a while now and I am still having trouble. I have worked on not using select and activate within my excel code but I am still having trouble with my code now. I am trying to automate my excel workbook as much as I can for easier use.
Sub Copy()
Dim Cell As Range
Dim myRow As Long
myRow = 1
With Sheets("Sheet1")
For Each Cell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
If Cell.Value = "Tuck Chow" And Cell.Offset(0, 1).Value = "OPT" Then
.Rows(Cell.Row).Copy Destination:=Sheets("Sheet2").Rows(myRow)
myRow = myRow + 1
End If
Next Cell
End With
End Sub
I would do something like this:
Sub Copy()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim newRow As Long
'setting sheets
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
Set sh2 = ThisWorkbook.Worksheets("Sheet2")
With sh1
For Each cel In .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
If cel.Value = "Tuck Chow" And cel.Offset(0, 1).Value = "OPT" Then
'getting new row on Sheet2
If sh2.Cells(1, 1) = "" Then
newRow = 1
Else
newRow = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
'copying
cel.EntireRow.Copy Destination:=sh2.Cells(newRow, 1)
End If
Next cel
End With
'deselecting row
sh2.Cells(1, 1).Select
End Sub
Try:
Option Explicit
Sub test()
Dim LastRow1 As Long, LastRow2 As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow1
If .Range("A" & i).Value = "Tuck Chow" And .Range("B" & i).Value = "OPT" Then
LastRow2 = ThisWorkbook.Worksheets("Sheet2").Cells(ThisWorkbook.Worksheets("Sheet2").Rows.Count, "A").End(xlUp).Row
.Rows(i).Copy ThisWorkbook.Worksheets("Sheet2").Rows(LastRow2 + 1)
End If
Next i
End With
End Sub
I have the following code which I am using to loop through a worksheet. Each row needs to be copied a certain number of times and the new rows pasted at the bottom, after the last row that currently has any text. The number of rows to copy for each present row is in the cell for column BU of that row.
Hence, in order to do this, I have created the following loop to move through each row and use the cell value in column BU to copy cells in columns A through BT, then paste after the last active visible row.
However, it's not working well.
Any thought?
Sub Transfer()
Application.ScreenUpdating = False
Dim lastrow As Long, lngRows
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row + 1
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rowCount As Long
Set wsSource = Worksheets("Forecasted Movement")
With wsSource
rowCount = .Cells(.Rows.Count, "A").End(xlUp).Row ' <-- modifed this line
On Error Resume Next
For i = 2 To rowCount
If .Cells(i, "BU").Value > 0 Then
lngRows = .Cells(i, "BU").Value
Range(Cells(i, 1), Cells(i, 72)).specialcells(xlCellTypeVisible).Copy
wsSource.Cells(lastrow, 1).Resize(lngRows).PasteSpecial Paste:=xlPasteValues
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
If this is all in the same worksheet ( as the code suggests) the your lastrow is your problem. You need to recalculate it everytime you paste a new row.
Sub Transfer()
Application.ScreenUpdating = False
Dim lastrow As Long, lngRows
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rowCount As Long
Set wsSource = Worksheets("Forecasted Movement")
With wsSource
rowCount = .Cells(.Rows.Count, "A").End(xlUp).Row ' <-- modifed this line
On Error Resume Next
For i = 2 To rowCount
If .Cells(i, "BU").Value > 0 Then
lngRows = .Cells(i, "BU").Value
Range(Cells(i, 1), Cells(i, 72)).specialcells(xlCellTypeVisible).Copy
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 ' recalculate this for the next blank row
wsSource.Cells(lastrow, 1).Resize(lngRows).PasteSpecial Paste:=xlPasteValues
End If
Next i
End With
Application.ScreenUpdating = True
End Sub