Looking for VBA to copy cell above (in column E) if cell in E is empty and AJ is anything other than empty. Currently this is copying the cell above but is not taking into account the AJ column. Fairly new to VBA and not sure where I am going wrong. Any input is greatly appreciated.
Sub CopyFIN() 'copies FIN from account above if E is empty and AJ is anything other than empty
Dim lr As Long
Dim rcell As Range
Dim col As Range
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 6).End(xlUp).Row
Set col = Range("E12:E" & lr)
Set col2 = Range("AJ12:AJ" & lr)
For Each rcell In col2
If rcell.Value <> "" Then
End If
Next
For Each rcell In col
If rcell.Value = "" Then
rcell.Offset(-1, 0).Copy rcell
End If
Next
Application.ScreenUpdating = True
End Sub
Try this. Your first loop wasn't doing anything and your second was only checking column E.
Sub CopyFIN() 'copies FIN from account above if E is empty and AJ is anything other than empty
Dim lr As Long
Dim rcell As Range
Dim col As Range
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 6).End(xlUp).Row
Set col = Range("E12:E" & lr)
For Each rcell In col
If Len(rcell) = 0 And Len(Cells(rcell.Row, "AJ")) > 0 Then
rcell.Offset(-1, 0).Copy rcell
End If
Next
Application.ScreenUpdating = True
End Sub
I have this working code that gets the value from "sheet1" column C to set it as sheet name and make a new worksheet and copies the "testscript" sheet.
My problem is I only need to copy that has the column value with "Y".
Here is my code:
Dim rcell As Range
Dim Background As Worksheet
Set Background = ActiveSheet
For Each rcell In Range("C2:C500")
If rcell.Value <> "" Then
For rep = 1 To (Worksheets.Count)
If LCase(Sheets(rep).Name) = LCase(rcell) Then
MsgBox "This sheet already exists!"
Exit Sub
End If
Next
Sheets("TestScript").Copy After:=Sheets(Worksheets.Count)
Sheets(Sheets.Count).Name = rcell.Value
End If
Next rcell
Dim rcell As Range
Dim Background As Worksheet
Set Background = ActiveSheet
For Each rcell In Range("C2:C500")
'if rcell has value and same row column J is equal to "Y"
If rcell.Value <> "" And Sheets("Sheet1").Cells(rcell.Row, 10).Value = "Y" Then
For rep = 1 To (Worksheets.Count)
If LCase(Sheets(rep).Name) = LCase(rcell) Then
MsgBox "This sheet already exists!"
Exit Sub
End If
Next
Sheets("TestScript").Copy After:=Sheets(Worksheets.Count)
Sheets(Sheets.Count).Name = rcell.Value
End If
Next rcell
I'd go as follows
Option Explicit
Sub main()
Dim rcell As Range
With Sheets("Sheet1") ' reference your "source" sheet for subsequent range explicit qualification
For Each rcell In .Range("C2:C500").SpecialCells(xlCellTypeConstants) ' loop through wanted range not empty cells with "constant" (i.e. not formulas) values
If UCase(.Cells(rcell.Row, 10)).Value = "Y" Then ' check current cell row column J value
If Not IsSheetThere(rcell.Value) Then 'check there's no sheet named after current cell value
Sheets("TestScript").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = rcell.Value
End If
End If
Next
End With
End Sub
Function IsSheetThere(shtName As String) As Boolean
On Error Resume Next 'avoid any error at following line to stop the routine
IsSheetThere = Worksheets(shtName).Name = shtName 'try getting a sheet with the passed name. this will throw an error if no sheet is found with that name
End Function
I am working on the below code to insert same entire row below/beneath original one. I had a hard time fulfilling the requirement because I am just new to making macros.
I already tried searching but not able to code correctly. It is working to insert an empty row. But what I need is to insert the row that met the condition. Below is the screenshot/code for my macro.
Private Sub CommandButton1_Click()
Dim rFound As Range, c As Range
Dim myVals
Dim i As Long
myVals = Array("LB") '<- starts with 51, VE etc
Application.ScreenUpdating = False
With Range("F1", Range("F" & Rows.Count).End(xlUp))
For i = 0 To UBound(myVals)
.AutoFilter field:=1, Criteria1:=myVals(i)
On Error Resume Next
Set rFound = .Offset(2).Resize(.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
If Not rFound Is Nothing Then
For Each c In rFound
Rows(c.Row + 1).Insert
c.Offset(1, -1).Value = ActiveCell.Value
Next c
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub Test()
Dim rng As Range
Dim rngData As Range
Dim rngArea As Range
Dim rngFiltered As Range
Dim cell As Range
Set rng = Range("A1").CurrentRegion
'Exclude header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=6, Criteria1:="LB"
Set rngFiltered = rngData.Columns("F:F").SpecialCells(xlCellTypeVisible)
rng.AutoFilter Field:=6
For Each rngArea In rngFiltered.Areas
For Each cell In rngArea
'// When inserting a row,
'// iteration variable "cell" is adjusted accordingly.
Rows(cell.Row + 1).Insert
Rows(cell.Row).Copy Rows(cell.Row + 1)
Next
Next
End Sub
Below is the code I just used . Thank you!
Private Sub CommandButton2_Click()
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
End if
Next x
End Sub
I want to copy a range in Sheet1 range A1:A100 where in the each cells filled with value like "Animal", "Plant", "Rock", and "Sand". Then, I want paste in Sheet2 range B1:B100 with conditions if the value at Range A1:A100 is "Animal" paste with "1", if the value is "Plant" paste with "2", ect.
How I write the VBA code? With simple and reducing memory usage.
My code :
Sub copyrange()
Dim i As Long
Dim lRw As Long
Dim lRw_2 As Long
Application.ScreenUpdating = False
lRw = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
ThisWorkbook.Sheets("Sheet1").Activate
For i = 1 To lRw
Range("A" & i).Copy
lRw_2 = Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row + 1
Sheets("Sheet1").Activate
'I not sure for this one, the code is too long
Select Case ThisWorkbook.Sheets("sheet1").Range("A" & i).Value
Case "Animal"
With Sheets("Sheet2").Range("B" & lRw_2)
.Value = 1
End With
Case "Plant"
With Sheets("Sheet2").Range("B" & lRw_2)
.Value = 2
End With
Case "Rock"
With Sheets("Sheet2").Range("B" & lRw_2)
.Value = 3
End With
Case "Sand"
With Sheets("Sheet2").Range("B" & lRw_2)
.Value = 4
End With
End Select
Sheets("Sheet1").Activate
Next i
Application.ScreenUpdating = True
End Sub
Thanks in advance.
Try this:
Option Explicit
Public Sub replaceItems()
Application.ScreenUpdating = False
With Sheets(2).Range("B1:B100")
.Value2 = Sheets(1).Range("A1:A100").Value2
.Replace What:="Animal", Replacement:=1, LookAt:=xlWhole
.Replace What:="Plant", Replacement:=2, LookAt:=xlWhole
.Replace What:="Rock", Replacement:=3, LookAt:=xlWhole
.Replace What:="Sand", Replacement:=4, LookAt:=xlWhole
End With
Application.ScreenUpdating = True
End Sub
I known, this question has been asked thousands of times. But every time I picked up a solution appears error when i debug. (error 1004)
I work with a database with about 300000 lines, where more than half do not care. (I know that have filter, but wanted to erase to reduce the file and speed up the process).
Then if the column M has a keyword like "water", "beer" or "vodka" it will delete the row. I mean, don't need to be the exact word, just the keyword.
OBS: Row 1 it's a table title with the frozen line.
Thanks!
The following code works less than 4 seconds for processing your sample data on my machine:
Sub QuickDeleteRows()
Dim Sheet_Data As Worksheet, NewSheet_Data As Worksheet, Data As Range
Dim Sheet_Name As String, Text As String, Water As Long, Beer As Long, Vodka As Long
On Error GoTo Error_Handler
SpeedUp True
Set Sheet_Data = Sheets("SOVI")
Sheet_Name = Sheet_Data.Name
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Output(1 To LastRow - 1, 1 To 1) As Long
For i = 1 To LastRow - 1
Text = Cells(i + 1, 13)
Water = InStr(Text, "water")
Beer = InStr(Text, "beer")
Vodka = InStr(Text, "vodka")
If Water > 0 Or Beer > 0 Or Vodka > 0 Then Output(i, 1) = 1
Next
[S2].Resize(LastRow - 1, 1) = Output
LastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
Set Data = Sheet_Data.Range(Cells(1, 1), Cells(LastRow, LastColumn))
Set NewSheet_Data = Sheets.Add(After:=Sheet_Data)
Data.AutoFilter Field:=19, Criteria1:="=1"
Data.Copy
With NewSheet_Data.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
.Cells(1, 1).Select
.Cells(1, 1).Copy
End With
Sheet_Data.Delete
NewSheet_Data.Name = Sheet_Name
NewSheet_Data.Columns(19).Clear
Safe_Exit:
SpeedUp False
Exit Sub
Error_Handler:
Resume Safe_Exit
End Sub
Sub SpeedUp(SpeedUpOn As Boolean)
With Application
If SpeedUpOn Then
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayStatusBar = False
.DisplayAlerts = False
Else
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.DisplayAlerts = True
End If
End With
End Sub
In the future, please post code you've tried first for the community to help you out. That being said, try this out:
Sub Test()
Dim x as Long
Dim i as Long
x = Sheets("SOVI").Range("M" & Rows.Count).End(xlUp).Row
For i = x to 2 Step -1
If InStr(1, Range("M" & i).Value, "water", vbTextCompare) Or InStr(1, Range("M" & i).Value, "beer", vbTextCompare) Or InStr(1, Range("M" & i).Value, "vodka", vbTextCompare) Then
Range("M" & i).entirerow.delete
End If
Next i
End Sub
I would use a slightly different approach, with the Like and with Select Case - this will give you more versatility in the future if you would want to expand it to more types of drinks.
Sub FindDrink()
Dim lRow As Long
Dim i As Long
Dim sht As Worksheet
' always set your sht, modify to your sheet name
Set sht = ThisWorkbook.Sheets("Sheet1")
lRow = sht.Cells(sht.Rows.Count, "M").End(xlUp).Row
For i = lRow To 2 Step -1
Select Case True
Case (sht.Cells(i, "M").Value Like "*beer*") Or (sht.Cells(i, "M").Value Like "*water*") Or (sht.Cells(i, "M").Value Like "*vodka*")
Range("M" & i).EntireRow.Delete
Case Else
' if you decide to do other things in the future for other values
End Select
Next i
End Sub
use excel built in filtering functions for the maximum speed
Autofilter
Option Explicit
Sub main()
Dim keysToErase As Variant, key As Variant
keysToErase = Array("water", "beer", "vodka") '<--| list your keywords to delete matching column "M" rows with
Application.DisplayAlerts = False '<--| prevent alerts dialog box from appearing at every rows deletion
With Workbooks("test").Worksheets("SOVI").Range("A1").CurrentRegion '<--| this gets the range of all contiguous cells to "A1"
For Each key In keysToErase '<--| loop through keys
.AutoFilter field:=13, Criteria1:="*" & key & "*" '<--| filter column "M" with key
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete '<--| delete filtered cells, if any
Next key
.Parent.ShowAllData '<--| .. show all rows back...
End With
Application.DisplayAlerts = True '<--| allow alerts dialog box back
End Sub
AdvancedFilter
Option Explicit
Sub main2()
Application.DisplayAlerts = False '<--| prevent alerts dialog box from appearing at every rows deletion
With Workbooks("test").Worksheets("SOVI").Range("A1").CurrentRegion '<--| this gets the range of all contiguous cells to "A1"
.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Parent.Range("U1:U4") '<--| this filters on all keys you placed in cells "U2:U4" with cell "U1" with wanted data header
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete '<--| delete filtered cells, if any
.Parent.ShowAllData '<--| .. show all rows back...
End With
Application.DisplayAlerts = True '<--| allow alerts dialog box back
End Sub
Try with Below code
Sub test()
Application.DisplayAlerts = False
Dim lastrow As Long
Dim i As Long
Dim currentrng As Range
lastrow = Range("M" & Rows.Count).End(xlUp).Row
For i = lastrow To 2 Step -1
Set currentrng = Range("M" & i)
If ((currentrng Like "*water*") Or (currentrng Like "*beer*") Or (currentrng Like "*vodka*")) Then
currentrng.EntireRow.Delete shift:=xlUp
End If
Next i
Application.DisplayAlerts = True
End Sub