I have the below VB that someone helped me with that works well except I now need to make an addition. As it stands the VB is looking at Column "C" and if it is blank it will cut "A" & "B" and paste it to another sheet. What I want to do is also include "SHOT10","SHOT15" & "SHOT20" as well. Meaning if those are also found in Column "C" to be cut and paste to the other sheet as well.
CODE
Sub ClearRange3()
Dim myLastRow As Long
Dim i As Long
Application.ScreenUpdating = False
Sheets("Absence Line").Select
' Find last row
myLastRow = Cells(Rows.Count, "B").End(xlUp).Row
' Loop through range
For i = 2 To myLastRow
If Cells(i, "C").Value = "" Then
With Range(Cells(i, "A"), Cells(i, "B"))
.Copy
find_last_record = Worksheets("Duplicates").Range("A65536").End(xlUp).Row + 1
Sheets("Duplicates").Paste Destination:=Sheets("Duplicates").Range("A" & i)
.ClearContents
End With
End If
Next i
Application.ScreenUpdating = True
End Sub
Thanks in advance for any help you can provide.
This will work for you, Or is your friend.
Sub ClearRange3()
Dim myLastRow As Long
Dim i As Long
Application.ScreenUpdating = False
Sheets("Absence Line").Select
' Find last row
myLastRow = Cells(Rows.Count, "B").End(xlUp).Row
' Loop through range
For i = 2 To myLastRow
If Cells(i, "C").Value = "" Or Cells(i, "C").Value = "SHOT10" Or Cells(i, "C").Value = "SHOT15" Or Cells(i, "C").Value = "SHOT20" Then
With Range(Cells(i, "A"), Cells(i, "B"))
.Copy
find_last_record = Worksheets("Duplicates").Range("A65536").End(xlUp).Row + 1
Sheets("Duplicates").Paste Destination:=Sheets("Duplicates").Range("A" & i)
.ClearContents
End With
End If
Next i
Application.ScreenUpdating = True
End Sub
Related
I am trying to copy a few colums of data that meet a certain criteria and then paste the first column of the copied data into a specific column on a second spreadsheet by nation. I am stuck selecting data from the copied cells- the second if statement.
New Working Code
Sub SortData()
'Clear Data from Practices Sheet
Sheet2.Range("B6:F1000").Clear
a = Worksheets("Home").Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To a
If Worksheets("Home").Cells(i, 4).Value = "Active" And Worksheets("Home").Cells(i, 3).Value = "Denmark" Then
C = Worksheets("Home").Cells(i, 2).Copy
Worksheets("Practices").Activate
b = Worksheets("Practices").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Practices").Cells(b + 1, 2).Select 'column To paste data into
ActiveSheet.Paste
Worksheets("Home").Activate
ElseIf Worksheets("Home").Cells(i, 4).Value = "Active" And Worksheets("Home").Cells(i, 3).Value = "Netherlands" Then
C = Worksheets("Home").Cells(i, 2).Copy
Worksheets("Practices").Activate
b1 = Worksheets("Practices").Cells(Rows.Count, 4).End(xlUp).Row
Worksheets("Practices").Cells(b1 + 1, 4).Select
ActiveSheet.Paste
Worksheets("Home").Activate
ElseIf Worksheets("Home").Cells(i, 4).Value = "Active" And Worksheets("Home").Cells(i, 3).Value = "UK" Then
C = Worksheets("Home").Cells(i, 2).Copy
Worksheets("Practices").Activate
b = Worksheets("Practices").Cells(Rows.Count, 6).End(xlUp).Row
Worksheets("Practices").Cells(b + 1, 6).Select
ActiveSheet.Paste
Worksheets("Home").Activate
End If
Next
End Sub
How to make this more concise?
I recommend to reduce redundant code like this:
Don't use .Select and .Activate as I told in my first comment.
How to avoid using Select in Excel VBA
Use Option Explicit to make sure all variables are declared.
Don't use the same code lines over and over. Instead make a function/procedure or reduce redundancy like I did below.
Always use descriptive variable names instead of one letter names. Otherwise your code is very hard to read/understand by humans.
Option Explicit
Public Sub SortData()
'Clear Data from Practices Sheet
Worksheets("Practices").Range("B6:F1000").Clear
Dim LastUsedRow As Long
LastUsedRow = Worksheets("Home").Cells(Rows.Count, 3).End(xlUp).Row
Dim i As Long
For i = 3 To LastUsedRow
If Worksheets("Home").Cells(i, 4).Value = "Active" Then
Dim PasteColumn As Long
Select Case Worksheets("Home").Cells(i, 3).Value
Case "Denmark": PasteColumn = 2
Case "Netherlands": PasteColumn = 4
Case "UK": PasteColumn = 6
Case Else: PasteColumn = 0 'we need this to cancel copy
End Select
If PasteColumn > 0 Then
Dim PasteLastRow As Long
PasteLastRow = Worksheets("Practices").Cells(Rows.Count, PasteColumn).End(xlUp).Row
Worksheets("Home").Cells(i, 2).Copy
Worksheets("Practices").Cells(PasteLastRow + 1, PasteColumn).Paste
End If
End If
Next i
End Sub
I have had a go at what i think you mean. But there are many errors and inconsistencies throughout as noted in the comments.
Sub SortData()
Dim a As Long, c As Range, sh As Worksheet, ws As Worksheet, b As Long
Set sh = ThisWorkbook.Sheets("Home")
Set ws = ThisWorkbook.Sheets("Practices")
a = sh.Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To a
If sh.Cells(i, 4).Value = "Active" Then
Set c = sh.Range(Cells(i, "A"), Cells(i, "D"))
End If
If c.Columns(3) = "Denmark" Then
b = ws.Cells(Rows.Count, 5).End(xlUp).Row
c.Copy
ws.Cells(i, 2).PasteSpecial
ElseIf c.Cells(i, 3) = "Netherlands" Then
b = ws.Cells(Rows.Count, 5).End(xlUp).Row
c.Copy
ws.Cells(i, 2).PasteSpecial
ElseIf C.Cells(i, 3) = "UK" Then
b = ws.Cells(Rows.Count, 5).End(xlUp).Row
c.Copy
ws.Cells(b + 1, 6).PasteSpecial
End If
Next
End Sub
I want to delete entire row when all 3 numeric values in cells in columns G,H,I are equal. I wrote a vba code and it does not delete nothing. can Someone advise?
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
Set rng = Range("G2", Range("G2").End(xlDown))
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = 2 To NumRows
Cells(i, 7).Select
If Cells(i, 7).Value = Cells(i, 8).Value = Cells(i, 9).Value Then
EntireRow.Delete
Else
Selection.Offset(1, 0).Select
End If
Next i
End Sub
Try this code. When deleting rows, always start from last row and work towards first one. That way you are sure you wont skip any row.
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = NumRows + 1 To 2 Step -1
If Cells(i, 7).Value = Cells(i, 8).Value And Cells(i, 7).Value = Cells(i, 9).Value Then
Cells(i, 7).EntireRow.Delete
Else
End If
Next i
End Sub
Remember when you delete rows, all you need to loop in reverse order.
Please give this a try...
Sub remove_dup()
Dim NumRows As Long
Dim i As Long
NumRows = Cells(Rows.Count, "G").End(xlUp).Row
For i = NumRows To 2 Step -1
If Application.CountIf(Range(Cells(i, 7), Cells(i, 9)), Cells(i, 7)) = 3 Then
Rows(i).Delete
End If
Next i
End Sub
You can delete all rows together using UNION. Try this
Sub remove_dup()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim cel As Range, rng As Range
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row 'last row with data in Column G
For i = lastRow To 2 Step -1 'loop from bottom to top
If .Range("G" & i).Value = .Range("H" & i).Value And .Range("G" & i).Value = .Range("I" & i).Value Then
If rng Is Nothing Then 'put cell in a range
Set rng = .Range("G" & i)
Else
Set rng = Union(rng, .Range("G" & i))
End If
End If
Next i
End With
rng.EntireRow.Delete 'delete all rows together
End Sub
What I'm trying to do is remove any rows where a cell value in a specific column matches what is defined to remove. After that is done re-sequence the value in another column by group.
Using the example below:
I want to look at column B and remove any rows that have a value of A or C. Then I want to basically renumber after the dot (.) in column A to reset itself.
Before Macro Code Fig. 1
After value A and C are removed Fig. 2
Final list after column A is renumbered Fig. 3
I figured out how to remove the rows using this code, but stuck on what to do next:
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long
For RowToTest = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" _
Then _
Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
End Sub
This will be easier to do looping from the top down (using step 1 instead of step -1). I've tried to stay true to your original coding and made this:
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long
Dim startRow As Long
Dim i As Integer
startRow = 2
'Clear the rows that have "A" or "C" in column B
For RowToTest = Cells(Rows.Count, 1).End(xlUp).Row to startRow To Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" _
Then _
Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
'If the left 3 characters of the cell above it are the same,_
'then increment the renumbering scheme
For RowToTest = startRow To Cells(Rows.Count, 1).End(xlUp).Row
If Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), "\")) = Left(Cells(RowToTest, 1).Offset(-1, 0).Value, InStr(1, Cells(RowToTest, 1), "\")) Then
i = i + 1
Cells(RowToTest, 1).Value = Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), ".")) & i
Else
i = 0
Cells(RowToTest, 1).Value = Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), ".")) & i
End If
Next RowToTest
End Sub
EDIT: I've updated it to compare all of the string before the backslash and compare using that.
EDIT++: It has been brought to my attention that when deleting rows it is better to work from the bottom up (step -1) to ensure every row is accounted for. I've re-implemented the original steps in the first code.
Admittedly, this isn't probably the most efficient, but it should work.
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long, i As Long
Application.ScreenUpdating = False
For RowToTest = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" Then Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
Dim totalRows As Long
totalRows = Cells(Rows.Count, 1).End(xlUp).Row
Dim curCelTxt As String, aboveCelTxt As String
For i = totalRows To i Step -1
If i = 1 Then Exit For
curCelTxt = Left(Cells(i, 1), WorksheetFunction.Search("\", Cells(i, 1)))
aboveCelTxt = Left(Cells(i - 1, 1), WorksheetFunction.Search("\", Cells(i - 1, 1)))
If curCelTxt = aboveCelTxt Then
Cells(i, 1).Value = ""
Else
Cells(i, 1).Value = WorksheetFunction.Substitute(Cells(i, 1), Right(Cells(i, 1), Len(Cells(i, 1)) - WorksheetFunction.Search(".", Cells(i, 1))), "0")
End If
Next i
Dim rng As Range, cel As Range
Dim tempLastRow As Long
Set rng = Range("A1:A" & Cells(Rows.Count, 2).End(xlUp).Row)
For Each cel In rng
If cel.Offset(1, 0).Value = "" Then
tempLastRow = cel.End(xlDown).Offset(-1, 0).Row
If tempLastRow = Rows.Count - 1 Then
tempLastRow = Cells(Rows.Count, 2).End(xlUp).Row
cel.AutoFill Destination:=Range(cel, Cells(tempLastRow, 1))
Exit For
Else
cel.AutoFill Destination:=Range(cel, Cells(tempLastRow, 1))
End If
End If
Next cel
Application.ScreenUpdating = True
End Sub
Mainly, I discovered that you can use AutoFill to fix the last number in the string. Meaning if you AutoFill this text, CAT\Definitions.0 down, you get the number updating as you drag/fill.
I am trying to write a vba script that will filter on two columns, column A and column D. Preferably, I want to create a button that will execute once I have chosen the filter criteria. Sample of input data below.
Sub Compiler()
Dim i
Dim LastRow As Integer
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet4").Range("A2:J6768").ClearContents
For i = 2 To LastRow
If Sheets("Sheet1").Cells(i, "A").Values = Sheets("Sheet3").Cells(3, "B").Values And Sheets("Sheet1").Cells(i, "D").Values = Sheets("Sheet3").Cells(3, "D").Values Then
Sheets("Sheet1").Cells(i, "A" & "D").EntireRow.Copy Destination:=Sheets("Sheet4").Range("A" + Rows.Count).End(xlUp)
End If
Next i
End Sub
Sample Data to run vba script
I have included my previous answer's changes into the full code block that is now provided below.
Sub Compiler()
Dim i
Dim LastRow, Pasterow As Integer
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("Sheet4")
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet4").Range("A2:J6768").ClearContents
For i = 2 To LastRow
If Sheets("Sheet1").Range("A" & i).Value = Sheets("Sheet3").Range("B3").Value And Sheets("Sheet1").Range("D" & i).Value = Sheets("Sheet3").Range("D3").Value Then
Pasterow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
Sheets("Sheet1").Rows(i).EntireRow.Copy Destination:=Sheets("Sheet4").Range("A" & Pasterow)
End If
Next i
Sheets("sheet4").Rows(1).Delete
End Sub
Sheets("Sheet1").Cells(i, "A").Values
Sheets("Sheet3").Cells(3, "B").Values
etc
You keep using values. Don't you mean value?
This answered the question I was asking, I tried to work with Dan's answer but didn't get very far.
Private Sub CommandButton1_Click()
FinalRow = Sheets("Sheet1").Cells(rows.Count, 1).End(xlUp).Row
Sheets("Sheet4").Range(Sheets("Sheet4").Cells(1, "A"), Sheets("Sheet4").Cells(FinalRow, "K")).ClearContents
If Sheets("Sheet4").Cells(1, "A").Value = "" Then
Sheets("Sheet1").Range("A1:K1").Copy
Sheets("Sheet4").Range(Sheets("Sheet4").Cells(1, "A"), Sheets("Sheet4").Cells(1, "K")).PasteSpecial (xlPasteValues)
End If
For x = 2 To FinalRow
ThisValue = Sheets("Sheet1").Cells(x, "A").Value
ThatValue = Sheets("Sheet1").Cells(x, "D").Value
If ThisValue = Sheets("Sheet3").Cells(3, "B").Value And ThatValue = Sheets("Sheet3").Cells(3, "D").Value Then
Sheets("Sheet1").Range(Sheets("Sheet1").Cells(x, 1), Sheets("Sheet1").Cells(x, 11)).Copy
Sheets("Sheet4").Select
NextRow = Sheets("Sheet4").Cells(rows.Count, 1).End(xlUp).Row + 1
With Sheets("Sheet4").Range(Sheets("Sheet4").Cells(NextRow, 1), Sheets("Sheet4").Cells(NextRow, 11))
.PasteSpecial (xlPasteFormats)
.PasteSpecial (xlPasteValues)
End With
End If
Next x
Worksheets("Sheet4").Cells.EntireColumn.AutoFit
End Sub
I have the below code that works well, however what I will like to do is have the code modified to copy the data it will clear to Sheet2 for further investigating the continue to clear from the original sheet. All the code itself does is look at G and H. If H is smaller than G it then clears the contents of A:J. What I want now is to still clear the contents if the criteria is met however I want a copy of the cells copied to Sheet2 as well.
Sub ClearRange()
Dim myLastRow As Long
Dim i As Long
Application.ScreenUpdating = False
' Find last row
myLastRow = Cells(Rows.Count, "G").End(xlUp).Row
' Loop through range
For i = 5 To myLastRow
If Cells(i, "H").Value < Cells(i, "G").Value Then Range(Cells(i, "A"), Cells(i, "J")).ClearContents
Next i
Application.ScreenUpdating = True
End Sub
Thanks in advance for any assistance you can provide.
You can just update this portion of your code:
' Loop through range
For i = 5 To myLastRow
If Cells(i, "H").Value < Cells(i, "G").Value Then
With Range(Cells(i, "A"), Cells(i, "J"))
.Copy
Sheets("Sheet2").Paste Destination:=Sheets("Sheet2").Range("A" & i)
.ClearContents
End With
End If
Next