So, after roughly 3 hours or more of searching google and for an answer, I can't seem to find an answer that fits my specific case. I've been grappling with a macro, and finally have it mostly working BUT getting it to copy/paste to a new sheet is vexing me to no ends. Here's the copy/paste lines (also the prior copy/paste that I tried to make work before I gave up on it) :
Sub Filtration()
Application.Goto Sheet1.Range("R1")
Application.ScreenUpdating = False
Dim writeRow As Integer
Dim percentage As Double
'to create skip conditions for row 1 & 2
counter = 1
For Each Cell In Sheets(1).Range("R:R")
'second part of skip condition
If counter > 2 Then
'creates condition to ignore blank cells or cells with a zero or negative number
If Cell.Value = "" Or Cell.Value <= 0 Then
Else
'creates a way to ignore offset cells if =< 0 (might need to add in for blank too)
If Cell.Offset(, -2).Value <= 0 Then
percentage = 0
Else
percentage = Cell.Value / Cell.Offset(, -2).Value
End If
'divide the current cell's value by the the cell one column over's value and compare
If percentage > 0.02 Then
Set Mastersheet = Worksheets("Sheet1") ' Copy From this sheet
Set Pastesheet = Worksheets("Sheet2") ' to this sheet
Cell.EntireRow.Copy ' copy the row from column O that meets that requirements (above, 1 and also win in Q)
'Pastesheet.Cells(lastRow + 1, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
Dim LastRow As Long
With Pastesheet
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' get last row in column "A
.Cells(LastRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
End With
End If
End If
End If
'final part of skip condition to ignore the two headers - has to be here to work, before next but after the last End IF
counter = counter + 1
Next
Application.ScreenUpdating = True
End Sub
The commented copy/paste just errors out on me on the writeRow part and couldn't figure out why, and searching turned up no reasons either. The second half works but just overwrites the same row over and over, and all the answers and examples I found out there claim it should work, so I'm at a loss. Does anyone have any ideas?
I guess you are after something like the code below (this section of code takes care only for the Paste section):
Dim LastRow As Long
Dim LastCell As Range
With Pastesheet
' safer way to get the last row
Set LastCell = .Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, _
searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
LastRow = LastCell.Row
End If
.Cells(LastRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
End With
Related
I have a constant task at work where I need to copy a list of numbers to another sheet. In that sheet, I need to paste those numbers one by one, in a cell to the right of cells with a certain value(that repeats in a column). (notice that the target table is sorted by that value -"מודל תגובה" and there are hidden rows.
It's hard to explain so I hope the images will do.
I tried to write suitable code but I kept getting different errors.
It seems that problems occur when copying the cell values to the target cells.
Dim i As Integer
i = 4
Do While IsEmpty(Cells(i, 1).Value) = False
Worksheets(1).Select
Cells(i, 1).Copy
Worksheets(2).Select
Cells.Find(What:="מודל תגובה", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, -1).Activate
If IsEmpty(ActiveCell.Value) = False Then
Selection.FindNext(After:=ActiveCell).Activate
ActiveCell.Offset(0, -1).Paste
Else
ActiveCell.Offset(0, -1).Select
ActiveCell.Paste
End If
i = i + 1
Loop
sorry for the shitty code(literally my first macro).
The solution would be to loop through the visible cells of the filtered range only.
Make sure the destination is filtered for "מודל תגובה" before running this code. It needs to look like your second image before running this code.
Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets(1)
Dim DestinationSheet As Worksheet
Set DestinationSheet = Worksheets(2)
Dim LastRow As Long
LastRow = DestinationSheet.Cells(DestinationSheet.Rows.Count, "B").End(xlUp).Row
Dim VisibleCells As Range
On Error Resume Next 'next line errors if no visible cells so we turn error reporting off
Set VisibleCells = DestinationSheet.Range("A2", "A" & LastRow).SpecialCells(xlCellTypeVisible)
On Error Goto 0 'turn error reporting on or you won't see if other errors occur
If VisibleCells Is Nothing Then 'abort if no cells are visible in the filter
MsgBox "No cells to paste at"
Exit Sub
End If
Dim SourceRow As Long
SourceRow = 4 'start row in your source sheet
Dim Cell As Range
For Each Cell In VisibleCells.Cells 'loop through visible cells
Cell.Value = SourceSheet.Cells(SourceRow, "A").Value 'copy value
SourceRow = SourceRow + 1 'incerease source row
Next Cell
Make sure to define DestinationSheet and SourceSheet with your sheets names.
Try this:
Dim i As Integer
Dim Last_Row as Long
Worksheets(1).Select
'The "1" Of the line below means that the variable gonna count the rows of the first column (A)
Last_Row = Application.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:A" & Last_Row).Copy
Worksheets(2).Select
Range("A1").Select
ActiveSheet.Paste
If cell in column I1-I14 is greater than cell in column J1-J14, I want to cut the entire row and paste values to the first empty row. (From row 16 and down.)
If cell i is greater than cell j, cut row and paste values to first empty row (row 16 in this example)
This code just pastes in the first row:
Sub Knapp6_Klicka()
Dim i As Long
Dim j As Long
j = 1
For i = 3 To 500
If Cells(i, 9).Value > Cells(i, 10).Value Then
Cells(i, 12).EntireRow.Cut Sheets("Blad1").Range("A" & j)
j = j + 1
End If
Next i
End Sub
I tried to combine the paste with two different solutions.
One like this, where I recorded a macro and went to the last cell, then up to the first empty cell:
Range("A1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
And one solution that I found on an Excel community:
Sub compareresult()
Dim row1 As Integer
Dim row2 As Integer
row2 = 1
For row1 = 8 To 500
If sheet1.Cells(row1, 11).value > sheet1.Cells(row1, 9).value Then
sheet1.Cells(row1, 1).EntireRow.Copy Sheets(11).Cells(row2, 1)
row2 = row2 + 1
End If
Next row1
End Sub
If cell in column I1-I14 is greater than cell in column J1-J14, i want to cut entire row and paste values to the first empty row. (From row 16 and down)
Here is a method which doesn't cut and paste in a loop. Since you are not deleting the row or "cutting and inserting" the row, here is a simple approach. The below code follows a basic logic
Logic
Loop and identify the range.
If found, then copy the range in 1 go.
Finally clear the range which was copied (if copied).
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rngToCopy As Range
Dim i As Long
'~~> Change this to relevant sheet
Set ws = Sheet1
With ws
'~~> Loop and identify the range
For i = 2 To 14
If .Range("I" & i).Value2 > .Range("J" & i).Value2 Then
If rngToCopy Is Nothing Then
Set rngToCopy = .Rows(i)
Else
Set rngToCopy = Union(rngToCopy, .Rows(i))
End If
End If
Next i
'~~> If found then copy and clear
If Not rngToCopy Is Nothing Then
rngToCopy.Copy .Rows(16)
rngToCopy.Clear
End If
End With
End Sub
EDIT:
To incorporate new edits
Works perfectly! Thanks! :) I failed to fully describe my problem.. What i also need is to paste it as special (only paste the value and not the formulas). Do you got any quick solution for that? – Johl 5 hours ago
Replace
rngToCopy.Copy .Rows(16)
to
rngToCopy.Copy
DoEvents
.Rows(16).PasteSpecial Paste:=xlPasteValues
Have a try with this.
It's based on the range you gave. Skipped over row 1 since you have headers in it.
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to
For i = 2 To 14 'Your range of rows to check
If ws.Range("I" & i) > ws.Range("J" & i) Then
ws.Range("I" & i).EntireRow.Cut ws.Range("A" & lRow) 'Cutting the whole row so you use column A to cut to
lRow = lRow + 1 'Move down 1 row for where to cut to
End If
Next i
Edit:
Because you only want the values to copy accross we can't use Cut and PasteSpecial xlValues so instead we will duplicate the value of the entire row to the new location, then clear the row (filling in for the cutting part). If clear is too much we can just ClearContents to remove the values in the cells instead of the formatting if that happens. Make sure to always save before running VBA code for the first time.
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Blad1") 'Your sheet name
lRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1 'Finding the last row
If lRow < 16 Then lRow = 16 'The starting row you want to cut to
For i = 2 To 14 'Your range of rows to check
If ws.Range("I" & i) > ws.Range("J" & i) Then
ws.Range("A" & lRow).EntireRow.Value = ws.Range("I" & i).EntireRow.Value 'Copying the values over
ws.Range("I" & i).EntireRow.Clear 'Clear the row
lRow = lRow + 1 'Move down 1 row for where to cut to
End If
Next i
Your code is doomed to failure because you do not take into consideration that you are cutting the found row. Think about what that means. Your row with the In,Out is row 15 and you wish to paste to row 16. If you cut row 5 (for example) then rows 15 and 16 will become rows 14 and 15. It also means that your next row (which you think will be row 6) will actually be what was row 7 before the cut.
So, I'm looking for a way to skip specific columns in a row copy. I'm working with doing a bunch of loops to copy/paste from a bunch of sheets of variable sized reports and I want a way to simply skip a column or columns in a row copy since I can't just do a entirecolumn.delete to deal with the excess and doing a counter system might get broken. I guess what I'd like (which doesn't exist as far as I know) is something like a row copy columns 3 to 5 ignore.
Dim LastRow As Long
Dim LastCell As Range
For Each Cell In Sheet10.Range("A:B")
If Cell.Value Like "*Total*" Then
Set Mastersheet = Sheet10
Set Pastesheet = Sheet3
Cell.EntireRow.Copy
With Pastesheet
Set LastCell = Pastesheet.Cells.Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
LastRow = LastCell.Row
End If
Pastesheet.Cells(LastRow + 1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End If
Next
Here is how i would accomplish your task, broken-down into steps.
Dim rw As Range
'Step 1: Insert helper column
Columns(3).Insert
'Step 2: If any cell in columns A or B contain the word "Total", put "1" in the helper column
For Each rw In Worksheets("Sheet10").UsedRange.Rows
If rw.Cells(1, 1).Value Like "*Total*" Or rw.Cells(1, 2).Value Like "*Total*" Then
rw.Cells(1, 3).Value = "1"
End If
Next
'Step 3: Filter using the helper column, hide the helper column and 3 other columns, copy(offset removes header row), paste to sheet3 lastrow +1
With Range("A1").CurrentRegion
.AutoFilter Field:=3, Criteria1:="1"
.Columns("C:F").Hidden = True
.Offset(1).SpecialCells(xlVisible).Copy Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
'Step 4: Clean up Sheet10, or macro will not work next time
With Sheet10
.AutoFilterMode = False
.Columns.Hidden = False
.Rows.Hidden = False
.Columns(3).Delete
End With
I'm at a loss on this and need some help. I've lurked around at answers and have Frankensteined together some code for a macro but it just isn't working.
Here is part of what I have so far:
With ActiveSheet
Firstrow = 1
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For lrow = Lastrow To Firstrow Step -1
With .Cells(lrow, "G")
Range("G1").Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
End With
Next lrow
End With
I have a very similar block of code before this that deletes crap from the text files I'm importing and it works perfectly through all the number of rows. When I run the same thing with this formula, it only puts the formula in G1 and doesn't cycle through the rest of the sheet. I've tried this and it works, but copies down through all million plus rows:
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
Selection.AutoFill Destination:=Range("G:G")
I've tried this and then run the same code that gets rid of the text file crap but I get an error "End If without block If".
To fill the formula in one cell at a time you need to cycle through them; don't keep relying on the ActiveCell property.
With ActiveSheet
Firstrow = 1
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For lrow = Lastrow To Firstrow Step -1
.Cells(lrow, "G").FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
Next lrow
End With
But you can speed things up by putting the formula into all of the cells at once.
With ActiveSheet
Firstrow = 1
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range(.Cells(Firstrow, "G"), .Cells(Lastrow, "G"))
.FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
End With
End With
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
Another version, to dynamically select the columns based on their titles. Comments included.
Dim row As Range
Dim cell As Range
Static value As Integer
'Set row numbers
'Find the starting row. Located using Title of column "Start" plus whatever number of rows.
Dim RowStart As Long
Set FindRow = Range("A:A").Find(What:="Start", LookIn:=xlValues)
RowStart = FindRow.row + 1
'End of the range. Located using a "finished" cell
Dim RowFinish As Long
Set FindRow = Range("A:A").Find(What:="Finished", LookIn:=xlValues)
RowFinish = FindRow.row - 1
'Set range - Goes Cells(Rownumber, Columnnumber)
'Simply ammend RowStart and RowFinish to change which rows you want.
' In your case you need to change the second column number to paste in horizontally.
Set rng = Range(Cells(RowStart, 1), Cells(RowFinish, 1))
'Start the counter from the starting row.
value = RowStart
For Each row In rng.Rows
For Each cell In row.Cells
'Insert relevant formula into each cell in range.
cell.Formula = _
"=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
'Increment row variable.
value = value + 1
Next cell
Next row
So my problem is this. I have a workbook with lets say 2 sheets. I have automatically created sheet2 from another program and sheet1 where I would like only some of the information from sheet2.
I am now trying to create a macro that would check each row starting from 14 with the value in E% greater than 15. If the condition is met I would like the macro to copy cell value from C% and E% to sheet1 lets say in A5 and B5 and then proceed to next row in sheet2 pasting the valued to A6 B6 and so on.
Sub Test()
Dim rng As Range
Dim lastRow As Long
Dim cell As Variant
With Sheets("Sheet2")
lastRow = .Range("E" & .Rows.Count).End(xlUp).Row
Set rng = .Range("E14:E" & lastRow)
For Each cell In rng
If cell.Value > 15 Then
'And here is where it gets bugged. I know theres something wrong with the .select but I couldnt think of any other way to
'pick only just the 2 cells needed.
Range(cell.Offset(0, -1), cell.Offset(0, 0)).Select
Selection.Copy
'In here there should also be some code to select where to place the copyed
'data but since it already got bugged couldnt really find a solution for
'it..
Sheets("Sheet1").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
End If
Next
End With
End Sub
so I guess i'll put it together:
Sub Test()
Dim rng As Range
Dim lastRow As Long
Dim cell As Variant
dim count as long
count = 0
With Sheets("Sheet2")
lastRow = .Range("E" & .Rows.Count).End(xlUp).Row
Set rng = .Range("E14:E" & lastRow)
For Each cell In rng
If cell.Value > 15 Then
'And here is where it gets bugged. I know theres something wrong with the .select but I couldnt think of any other way to
'pick only just the 2 cells needed.
Range(cell.Offset(0, -1), cell.Offset(0, 0)).Select
Selection.Copy
'maybe use: Range(cell.Offset(0, -1), cell.Offset(0, 0)).copy
'In here there should also be some code to select where to place the copyed
'data but since it already got bugged couldnt really find a solution for
'it..
Sheets("Sheet1").Activate
Range("A5", B5).offset(count, 0).PasteSpecial 'this will make it so that it starts in a5, and moves down a row each time
count = count + 1 'dont forget to increment count
Sheets("Sheet2").Activate
End If
Next
End With
End Sub
and that's kinda a rough thing..
you might include some error handling like: if not cell.value = "" then or also if not isNumeric(cell.value) then and those together would ensure you're only processing non blank cells with numbers.