I need a macro to insert 2 cells moving existing data right. Sounds easy but been at it all day.
The issue is that the column B contains text and currency. If the cell contains currency, say $4661.52, I need to insert 2 cells, moving existing currency data right.
The length varies as does where the currency cells are. Late in the day
and confused.
Tried this and many variations :
Public Sub insertcells()
Const CLIENT As String = "B"
Dim Lastrow As Long
Dim i As Long
Application.ScreenUpdating = False
With ActiveSheet
Lastrow = .Cells(.Rows.Count, CLIENT).End(xlUp).Row
For i = Lastrow To 1 Step -1
If Cells(i, CLIENT).Value2 Like "$*" Then
.Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Check out this code.
Public Sub insertcells()
Const CLIENT As String = "B"
Dim Lastrow As Long
Dim i As Long
Application.ScreenUpdating = False
With ActiveSheet
Lastrow = .Cells(.Rows.Count, CLIENT).End(xlUp).Row
For i = Lastrow To 1 Step -1
If Cells(i, CLIENT).Value2 Like "$*" Or IsNumeric(Cells(i, CLIENT).Value) Then
.Cells(i, CLIENT).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(i, CLIENT).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Related
Good morning,
currently I have this code to delete rows without due date (Column J) and amount paid=0 (Column H).
Sub delete_rows()
Range("A1").End(xlDown).Select
Sheets("AA").Select
Range("J2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-5]=0,"""",RC[-5])"
Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J500"), Type:=xlFillDefault
Range("J2").End(xlDown).Select
Range("K2").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "J").End(xlUp).Row To 2 Step -1
If .Cells(line, "J") = "" Then
.Rows(line).Delete
End If
Next linha
End With
Application.ScreenUpdating = True
ActiveCell.FormulaR1C1 = "=IF(RC[-4]="""","""",RC[-4])"
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K500"), Type:=xlFillDefault
Range("K2").End(xlDown).Select
Range("J1").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "K").End(xlUp).Row To 2 Step -1
If .Cells(line, "K") = "" Then
.Rows(line).Delete
End If
Next line
End With
Application.ScreenUpdating = True
End sub()
I created a code with a defined number of lines...however it takes a long time for the code to run, because sometimes the number of lines is small and it always runs the 500 lines. What's the way to set the code so that it looks for the last filled row in column A, and then eliminate the rows where column H has values =0 and in column J no values?
Please check: find last cell. Also have a look at: avoid select.
Afterwards, I think you should be able to understand the following code, which should get you the required result:
Sub test()
Application.ScreenUpdating = False
'declare your variables
Dim ws As Worksheet
Dim Rng1 As Range, Rng2 As Range
Dim i As Long, lastRow As Long
Set ws = Sheets("AA")
With ws
'get last row in
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'set ranges for loop
Set Rng1 = Range(.Cells(2, "H"), .Cells(lastRow, "H"))
Set Rng2 = Range(.Cells(2, "J"), .Cells(lastRow, "J"))
'reverse loop
For i = Rng1.Rows.Count To 1 Step -1
'check conditions for cell in "H" and "J"
If Rng1.Cells(i) = 0 And Rng2.Cells(i) = "" Then
'defined ranges start at row 2, hence +1
ws.Rows(i + 1).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I delete rows based on the date in a column.
The dataset is around 85,000 rows and the macro can take from 30s to 5m+ with constant freezing.
I'm not sure if this is due to poorly written code or the size of the dataset.
Sub DeleteCurrentPeriod()
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets("Transaction list by date")
ws.Activate
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Insert column, autofill formula for range
Sheets("Transaction list by date").Select
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Selection.AutoFill Destination:=Range("AR2:AR100000"), Type:=xlFillDefault
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$100000").AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$100000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
You can give this a try (use F8 key to run it step by step)
Some suggestions:
Name your procedure and variables to something meaningful
Indent your code (you may use Rubberduckvba.com)
Split the logic in steps
Read about avoiding select and activate here
Code:
Public Sub DeleteCurrentPeriod()
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim transactionSheet As Worksheet
Set transactionSheet = ThisWorkbook.Worksheets("Transaction list by date")
' Turn off autofilter and show all data
transactionSheet.AutoFilterMode = False
' Find last row
Dim lastRow As Long
lastRow = transactionSheet.Cells(transactionSheet.Rows.Count, "AQ").End(xlUp).Row
' Define range to be filtered
Dim targetRange As Range
Set targetRange = transactionSheet.Range("A1:BE" & lastRow)
' Insert column
transactionSheet.Columns("AR:AR").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Add formula & calculate
transactionSheet.Range("AR2:AR" & lastRow).FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Application.Calculate
'Filter on new column for cells matching criteria
transactionSheet.Range("A1:BE" & lastRow).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
transactionSheet.Range("A2:BE" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
'Delete added column and remove filter
transactionSheet.Columns("AR:AR").Delete Shift:=xlToLeft
' Remove filter
transactionSheet.AutoFilterMode = False
'Select A1
Range("A1").Select
CleanExit:
' Turn on stuff again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
CleanFail:
MsgBox "An error occurred:" & Err.Description
GoTo CleanExit
End Sub
Let me know if it works
I've just made a couple of changes to how you work out the last row and how you do the calculation, it looks like you were comparing to a constant on the Control sheet. I wonder though why are you adding a column in and then deleting it, could you not just perform the calcs in column +1 after your data? Then you wouldn't have to create and delete the column.
'Insert column, autofill formula for range
Dim x as Long, y, lastrow
Sheets("Transaction list by date").Select
'Find the last row used
With Sheets("Transaction list by date")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
' Get the constant and perform the comparison, add "Y" to TRUE cells
x= Worksheets("Control").Cells(20,7).value
For y = 1 to lastrow
If Worksheets("Transaction list by date").Cells(y,44)>x then _
Worksheets("Transaction list by date").Cells(y,44).value = "Y"
Next y
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$" & lastrow ).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$" & lastrow).SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
Sub RemoveDups()
Const COMPARE_COL As Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp
a = Worksheets("Sheet1").UsedRange
nr = UBound(a, 1)
nc = UBound(a, 2)
ReDim aNew(1 To nr, 1 To nc)
rNew = 0
v = Date
For r = 1 To nr
tmp = a(r, COMPARE_COL)
If tmp <> v Then
rNew = rNew + 1
For c = 1 To nc
aNew(rNew, c) = a(r, c)
Next c
v = tmp
End If
Next r
Worksheets("Sheet1").UsedRange = aNew
End Sub
This is an answer written by Tim Williams I just set the range to used range and set v to Date, so if you copy and paste this it will search based on the current date you run the macro looking through column 1 (A) If you want to use a different date you'll have to redefine v, you can make that equal to the cell on your control sheet. Took 1 second to "delete" 85000 rows.
my goal is to delete rows with column 3 with the cell value that has inventory (>0) and column 4 that has the cell value TRUE in the current sheet. I tried to use the code to this website and I'm pretty sure I did something wrong where it says ActiveSheet.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Public Sub FilterStock()
ActiveSheet.Range("A1").AutoFilter Field:=4, Criteria1:="TRUE"
ActiveSheet.Range("A1").AutoFilter Field:=3, Criteria1:=">0"
Application.DisplayAlerts = False
ActiveSheet.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.AutoFilter.ShowAllData
End Sub
This code worked for me:
Sub DeletelRows()
Dim lastRow As Long
Dim debug1 As Variant
Dim debug2 As Variant
'Find the last non-blank cell in column C
lastRow = Cells(Rows.Count, 3).End(xlUp).Row
For x = lastRow To 2 Step -1 'Start at bottom and go up to avoid complications when the row is deleted.
debug1 = Cells(x, 3).Value 'You can set breakpoints to see what the values are.
debug2 = Cells(x, 4).Value
If (Cells(x, 3).Value > 0 And UCase(Cells(x, 4).Value) = "TRUE") Then
Rows(x).Delete
End If
Next x
End Sub
I'm looking for a VBA code to as the title specifies, delete data based on conditions
So I have Column A and Column B, Rows starts from 2 until the end of the sheet, so as an example If the value in B2 is "OK", I would like for the value in A2 to be cleared and then loop the same process until the end of both columns, this is what I have so far but it's not working properly:
Sub Clear()
Dim myLastRow As Long
Dim i As Long
Application.ScreenUpdating = False
Find last row
myLastRow = Cells(Rows.Count, "B").End(xlUp).Row
Loop through range
For i = 2 To myLastRow
If Cells(i, "B").Value = "OK" Then Range(Cells(i, "A")).ClearContents
Next i
Application.ScreenUpdating = True
End Sub
Quick fix for your code is to remove Range
Sub Clear()
Dim myLastRow As Long
Dim i As Long
Application.ScreenUpdating = False
'Find last row
myLastRow = Cells(Rows.Count, "B").End(xlUp).Row
' Loop through range
For i = 2 To myLastRow
' If Cells(i, "B").Value = "OK" Then Range(Cells(i, "A")).ClearContents
If Cells(i, "B").Value = "OK" Then Cells(i, "A").ClearContents
Next i
Application.ScreenUpdating = True
End Sub
Pay attention as Cells refers to the active sheet. In case you would like to run the code on a specific sheet you should better specifiy the sheet.
a bit of an odd one. I have a file with large amount of info that goes up to column "CH". Information in the workbook is spread through multiple tabs and when I consolidate data it copies everything except for the last column. Wonder if you could help me with that
Sub consolidation()
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidation").Delete
Application.DisplayAlerts = True
With ActiveWorkbook
Set Destination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
Destination.Name = "Consolidation"
End With
Dim i As Integer
Dim stOne As Worksheet
Dim stOneLastRow As Long
Dim stTwo As Worksheet
Dim stTwoLastRow As Long
Dim consolid As Worksheet
Dim consolidLastRow As Long
Set stOne = ThisWorkbook.Sheets("Sheet1")
Set stTwo = ThisWorkbook.Sheets("Sheet2")
Set consolid = ThisWorkbook.Sheets("Consolidation")
stOneLastRow = stOne.Range("C" & Rows.Count).End(xlUp).Row
stTwoLastRow = stTwo.Range("C" & Rows.Count).End(xlUp).Row
consolidLastRow = consolid.Range("C" & Rows.Count).End(xlUp).Row
For i = 6 To stOneLastRow
stOne.Select
If stOne.Range("C6").Value = "OM ID" Then
Cells(i, 3).Resize(1, 100).Copy
consolid.Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 2).Select
ActiveSheet.Paste
stOne.Select
End If
Next i
For i = 7 To stTwoLastRow
stTwo.Select
If stTwo.Range("C6").Value = "OM ID" Then
Cells(i, 3).Resize(1, 100).Copy
consolid.Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 2).Select
ActiveSheet.Paste
stTwo.Select
End If
Next i
End Sub
Initial code is taken from here: https://learn.microsoft.com/en-us/office/vba/api/excel.range.copy
Tried to copy rows based on the value in CH cell, but still copies everything except for that column...
Very weird :-(
Omg... I feel so stupid. The data starts from 3rd column, but I copied everything starting from the 2nd colum... macro works correctly, just needed to change the column...