Copy row of data based on criteria AND "label" that copied data in last column - excel

I have working code that checks for a criteria in each row, and if met, copies that whole row of data over to a different workbook. But! I need to be able to add text to the last column of the copied data (Column S) that essentially labels what criteria was met that made the code copy it over because I will soon be expanding to check for multiple different criteria.
So for every row that meets the criteria and gets copied, I want to add "Criteria1" next to it in column S in the new workbook (it will always be column S that will be the first available column).
I have mangled this code together through inheritance and all of your help, so I don't really even know where to begin.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim CoderBook As Workbook
Dim Referrals As Worksheet
Dim Review As Workbook
Dim Crit As Worksheet
Dim LastRow As Long
Dim NextRow As Long
Dim i As Long
Set CoderBook = Workbooks.Open("Coder Referrals.xlsx")
Set Referrals = CoderBook.Sheets("Sheet1")
Set Review = ThisWorkbook
Set Crit = Review.Sheets("Criteria")
'Search code
LastRow = Crit.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.ScreenUpdating = False
'Loop search code
For i = 2 To LastRow
'Specialized Criteria1 Check
If Crit.Range("F" & i) <> Crit.Range("G" & i) Or _
Crit.Range("I" & i) <> Crit.Range("J" & i) Then
'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
Referrals.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = Crit.Rows(i).Value
End If
Next i
'End loop code
CoderBook.Close SaveChanges:=True
Application.ScreenUpdating = True
End Sub

Split the or into two statements:
For i = 2 To LastRow
j = Referrals.Cells(Rows.Count, 1).End(xlUp).row + 1
'Specialized Criteria1 Check
If Crit.Range("F" & i) <> Crit.Range("G" & i) Then
'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
Referrals.Range("S" & j).Value = "Criteria1"
End If
If Crit.Range("I" & i) <> Crit.Range("J" & i) Then
Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
if Referrals.Range("S" & j).value = vbNullString then
Referrals.Range("S" & j).Value = "Criteria2"
Else
Referrals.Range("S" & j).Value = Referrals.Range("S" & j).Value & ", " & "Criteria2"
End if
Next i

Related

VBA code to delete extra rows in sheet with thousands of rows slowed significantly

We have an Excel macro that cleans up a spreadsheet containing thousands of rows. It starts from the bottom of the sheet and deletes rows that meet certain criteria.
I am told that this macro used to take a few minutes to run, and now it takes an hour. It used to zip up the spreadsheet, and now it takes about a second per row, which obviously adds up.
We recently upgraded from Excel 2007 to Excel 2016, so I am not sure if that is the cause. I have tried the macro on multiple computers and it is slow on all of them, so I don't think it's a faulty install issue. It may just be that the code is written inefficiently, or the spreadsheets have gotten larger. Not sure what else would cause this change.
Here is the code:
Sub DeleteExtraRows()
Dim RowCount As Integer
Dim i As Integer
RowCount = ActiveSheet.Cells(Rows.count, "B").End(xlUp).row
'Delete the Rows
For i = RowCount To 2 Step -1
Range("A" & i).Select
If (Range("A" & i).Style = "Neutral" And Range("AC" & i) = False) Or (Range("U" & i) = 1 And Range("V" & i) = 0 And Range("AC" & i) = False) Then
Rows(i).Delete
End If
Application.StatusBar = RowCount - i & " of " & RowCount & " Records Processed"
Next i
'Delete all the checkboxes
ActiveSheet.CheckBoxes.Delete
Range("A:A").Delete
Application.StatusBar = False
'Move to the top
Range("A2").Select
End Sub
Delete Thousands of Rows
I recently encountered a code that used the status bar in a similar way and slowed down the code dozens of times. Don't do that if it's not necessary.
Not tested.
Option Explicit
Sub DeleteExtraRows()
With ActiveSheet
'Delete the rows
Dim RowCount As Long: RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
Dim drg As Range
Dim i As Long
For i = 2 To RowCount
If (.Range("A" & i).Style = "Neutral" And .Range("AC" & i) = False) _
Or (.Range("U" & i) = 1 And .Range("V" & i) = 0 _
And .Range("AC" & i) = False) Then
If drg Is Nothing Then
Set drg = .Rows(i)
Else
Set drg = Union(drg, .Rows(i))
End If
End If
Next i
If Not drg Is Nothing Then
drg.Delete
End If
'Delete all the checkboxes
.CheckBoxes.Delete
.Range("A:A").Delete
'Move to the top
.Range("A2").Select
End With
End Sub

How to delete the rows based in excel sheet using column values

I have excel with 5 different sheets.
sheet3 and sheet4 i want delete rows based on the single column cell value.
in sheet 3 i want to delete rows based on H column cell values if H2="#N/A" and H503="#N/A" then delete entire rows.
in sheet 4 i want to delete rows based on b column cell values if B2="320857876",B3="32085678",B4="12133435" the delete the entire rows where B column cell values starts with 302.
and i want to delete all Data from 'C' column
My excel sheet is like this
Using excel file
Sub Create()
Dim LastRow As Long
Dim i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i) = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
You've got a few requirements there and your code is fairly light but regarding the #N/A part of it, you can't just test for that text using the value approach, which is the default property returned for a range object.
Sub Create()
Dim LastRow As Long, i As Long
LastRow = Range("B10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("B" & i).Text = "#N/A" Then
Range("B" & i).EntireRow.Delete
End If
Next
End Sub
... you need to use .Text to get that to work, or, If IsError(Range("B" & i)) Then is another approach.
The rest of your requirements is just logic. The rest of your code is relatively sound so you just need to work through it.
I hope that helps.
Sub delete_rows()
Dim sheet As Worksheet, cell As Range
Count = 1
For Each sheet In ThisWorkbook.Worksheets
If Count = 3 Then
lastrow = sheet.Cells(sheet.Rows.Count, "H").End(xlUp).Row
Set Rng = sheet.Range("H1:H" & lastrow)
For i = Rng.Cells.Count To 1 Step -1
If Application.WorksheetFunction.IsNA(Rng(i).Value) Then
Rng(i).EntireRow.Delete
ElseIf Rng(i).Value = "#NA" Then
Rng(i).EntireRow.Delete
End If
Next
ElseIf Count = 4 Then
lastrow = sheet.Cells(sheet.Rows.Count, "B").End(xlUp).Row
Set Rng = sheet.Range("B1:B" & lastrow)
Debug.Print (Rng(4).Text)
If Rng(2).Value = "320857876" And Rng(3).Value = "32085678" And Rng(4).Value = "12133435" Then
For i = Rng.Cells.Count To 1 Step -1
If Left(Rng(i).Value, 3) = "302" Then
Rng(i).EntireRow.Delete
End If
Next
End If
lastrow = sheet.Cells(sheet.Rows.Count, "C").End(xlUp).Row
Set Rng = sheet.Range("C1:C" & lastrow)
For Each cell In Rng
cell.Value = ""
Next cell
End If
Count = Count + 1
Next
End Sub

Match and retrieve values from another workbook

I'm very new to VBA so not sure where to start with this one. I have two separate workbooks saved in the same file location (Workbook 1 and Workbook 2)
what i'm looking for is When column C is populated in workbook 1, I want a macro that searches for that number in workbook 2 (column A).
If a match is found then I want the corresponding values from column C, D, E and G in Workbook 2 to be copied onto workbook 1.
Here is the values populated in Workbook1, then matched in Workbook2Here is the expected results, with the matched values populating Workbook1
Workbook 2 won't be opened by the user, they will just click a button in Workbook1 and it will populate the data.
I currently have this working but with Vlookups which has greatly slowed down opening workbook 1.
any help is appreciated.
Put this into the Code of the Sheet you are using in File1 and edit the Sheetnames and the Path. You dont need to press a button or anything, the macro will activate if the data in Column C changes and load the data of File2 into File1.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim Sheet1, Sheet2 As Worksheet
Dim CellChanged As Integer
Dim Path, File As String
Dim LastRow As Long
Path = "C:\Users\User\Desktop\2.xlsx" 'Edit Path File2
File = Right$(Path, Len(Path) - InStrRev(Path, "\"))
Set Sheet1 = ThisWorkbook.Worksheets("Tabelle1") 'Edit Sheet File1
Set KeyCells = Range("C:C")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
CellChanged = Target.Row
Workbooks.Open (Path)
Set Sheet2 = Workbooks(File).Worksheets("Tabelle1") 'Edit Sheet of File2
LastRow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If Sheet1.Range("C" & CellChanged).Value = Sheet2.Range("A" & i) Then
Sheet1.Range("D" & CellChanged).Value = Sheet2.Range("B" & i).Value 'Date
Sheet1.Range("E" & CellChanged).Value = Sheet2.Range("C" & i).Value 'Amount
Sheet1.Range("F" & CellChanged).Value = Sheet2.Range("F" & i).Value 'Payee
Sheet1.Range("G" & CellChanged).Value = Sheet2.Range("D" & i).Value 'Pol Number
Exit For
End If
Next i
Workbooks(File).Close savechanges:=False
End If
End Sub
EDIT:
Macro to start with a button with multiple edits (last cell change store in H1). Also added an Error handle.
Sub WithButton()
Dim KeyCells As Range
Dim Sheet1, Sheet2 As Worksheet
Dim CellChanged As Integer
Dim Path, File As String
Dim LastRow, LastData As Long
Dim Found As Boolean
On Error GoTo Handle
Set Sheet1 = ThisWorkbook.Worksheets("Tabelle1") 'Edit Sheet File1
If Sheet1.Range("H1").Value = "" Then
Sheet1.Range("H1").Value = 0
CellChanged = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
End If
If Sheet1.Cells(Rows.Count, "C").End(xlUp).Row > Sheet1.Range("H1").Value Then
Path = "C:\Users\L4R21D\Desktop\2.xlsx" 'Edit Path File2
File = Right$(Path, Len(Path) - InStrRev(Path, "\"))
CellChanged = Sheet1.Range("H1").Value + 1
Workbooks.Open(Path)
Set Sheet2 = Workbooks(File).Worksheets("Tabelle1") 'Edit Sheet of File2
LastRow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
LastData = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
For i = 1 To LastRow
If Sheet1.Range("C" & CellChanged).Value = Sheet2.Range("A" & i) Then
Sheet1.Range("D" & CellChanged).Value = Sheet2.Range("B" & i).Value
Sheet1.Range("E" & CellChanged).Value = Sheet2.Range("C" & i).Value
Sheet1.Range("F" & CellChanged).Value = Sheet2.Range("F" & i).Value
Sheet1.Range("G" & CellChanged).Value = Sheet2.Range("D" & i).Value
Found = True
End If
If Found = True Or i = LastRow Then
If CellChanged = LastData Then
Exit For
End If
If Found = True Then
Found = False
CellChanged = CellChanged + 1
End If
i = 0
End If
Next i
Workbooks(File).Close savechanges:=False
Sheet1.Range("H1").Value = CellChanged
End If
Exit Sub
Handle:
MsgBox("Error")
End Sub
The button driven answer is amazing and both of your answers were godsends! I have written one program in python and this is my first foray into VB, and your support helped immensely! One thing that I think could be improved on with the button driven answer, is that if there is something in column C on sheet 1 that is not a match the program failed; I added a line to iterate CellChanged + 1 if there was not a match on Sheet 1:
If Found = True Then
Found = False
CellChanged = CellChanged + 1
**Else
CellChanged = CellChanged + 1**
End If

Trying to delete all Rows until Cell (A,1) has certain value

Having issues in VBA
Trying to delete all rows until value in row 1 = "**GRAD*"
I get Runtime Error 438
Code Below
Public Sub Delete()
Dim i As Long
i = 1 'Start from row 1
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
Do Until .Range("A" & i).Value = "**GRAD"
If .Rage("A" & i).Value <> "**GRAD" Then
.Rows(i).EntireRow.Delete
Else: i = i + 1 'Only increment if the row hasn't been deleted to prevent skipping rows
End If
Loop
End With
Application.ScreenUpdating = True
End Sub
Some help would be appreciated, new to VBA.
L.Dutch already gave you the answer to your question
here's an alternative and faster approach
to delete all rows until value in column 1 = "**GRAD*"
Option Explicit
Public Sub Delete()
Dim lastRowToDelete As Long
Dim f As Range
With ThisWorkbook.Worksheets("Sheet0001") '<-- reference your worksheet
With Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) '<-- reference its columns "A" cells from row 1 sown to last not empty one
Set f = .Find(what:="**GRAD", LookIn:=xlValues, lookat:=xlWhole, after:=.Range("A" & .Rows.Count)) '<-- look for the first cell whose value is "**GRAD"
If f Is Nothing Then '<-- if not found then...
lastRowToDelete = .Rows(.Rows.Count).Row '<-- the last row to delete is the last row of the range
Else '<-- otherwise...
lastRowToDelete = f.Row - 1 '<-- the last row to delete is the one preceeding the one with the found cell
End If
End With
If lastRowToDelete > 0 Then .Range("A1:A" & lastRowToDelete).EntireRow.Delete 'delete all rows in a single shot
End With
End Sub
Typo? I read If .Rage("A" & i).Value <> "**GRAD" Then while it should be If .Range("A" & i).Value <> "**GRAD" Then

Merge empty cells with previous value

I have an Excel file with around 100,000 records. I have 6+ columns, the first five of which are:
Required Format:
So far I have :
Sub Main()
Dim i As Long
Dim j As Long
Dim sameRows As Boolean
sameRows = True
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To 4
If StrComp(Cells(i, j), Cells(i + 1, j), vbTextCompare) Then
sameRows = False
End If
Next j
If sameRows Then
Range(Cells(i, 4), Cells(i + 1, 4)).merge
End If
sameRows = True
Next i
End Sub
I am able to get below by running the macro by changing value in Range from 4 to 1/2/3/4 and running macro four times.
Please help me get the data in required format. I still need to merge the empty fields with the previous non empty field.
Pratik, listen carefully to Jeeped. Working with large data in Excel isn't ideal, and working with raw data in merged cells is staring into the abyss - it's a dark, dark place where Range referencing and things like Offset functions will show you a dimension of despair you never knew existed.
If you have this data in another format, say XML, that you've imported into Excel then use VBA to read the data, query it, etc. in its original format. If it exists in a database, then, again, use VBA to access that database and manipulate the recordsets as you wish. If this is your only source of data, then why not write it into an XML document or into VBA's own data storage options (like Collection or arrays).
If you have to use Excel then don't confuse raw data with data display. Yes, the merged cells might be easier to read for the human eye, but I'd just pose the question: is that your primary objective in conducting the merge?
If you must take that leap into the abyss - and you can see that at least two of us would advise against - then at least speed things up by reading from an array and merging rows at a time:
Sub OpenDoorsToHades()
Dim dataSheet As Worksheet
Dim v As Variant
Dim mergeCells As Range
Dim mergeAreas As Range
Dim i As Long
Dim blankStart As Long
Dim blankEnd As Long
Dim doMerge As Boolean
Dim c As Integer
Set dataSheet = ThisWorkbook.Worksheets("data") 'rename to your sheet
'Read values into array of variants
With dataSheet
v = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Value2
End With
'Check for blanks
For i = 1 To UBound(v, 1)
If IsEmpty(v(i, 1)) Then
If Not doMerge Then
blankStart = i - 1
doMerge = True
End If
Else
If doMerge Then
blankEnd = i - 1
For c = 1 To 4
With dataSheet
Set mergeCells = .Range( _
.Cells(blankStart, c), _
.Cells(blankEnd, c))
If mergeAreas Is Nothing Then
Set mergeAreas = mergeCells
Else
Set mergeAreas = .Range(mergeAreas.Address & _
"," & mergeCells.Address)
End If
End With
Next
mergeAreas.Merge
Set mergeAreas = Nothing
doMerge = False
End If
End If
Next
'Format the sheet
dataSheet.Cells.VerticalAlignment = xlCenter
Application.ScreenUpdating = True
End Sub
How about just populating the empty cells with the values above, so the values on the far right are associated with the same values that would've been in the merged cell. For example, if 19 is in cell A2, you can recreate the table starting in G2 with =IF(A2<>"",A2,G1), and this way all empty cells will be populated with the value above, pairing the values at the far right with the exact same values.
I tackled the same problem myself this week. Ambie's solution seemed overly complex, so I wrote something pretty simple to merge rows:
Sub MergeRows()
Sheets("Sheet1").Select
Dim lngStart As Long
Dim lngEnd As Long
Dim myRow As Long
'Disable popup alerts that appear when merging rows like this
Application.DisplayAlerts = False
lngStart = 2
lngEnd = 2
For myRow = 2 To Range("A" & Rows.Count).End(xlUp).Row 'last row
If Range("A" & (myRow + 1)).value = "" Then
'include row below in next merge
lngEnd = myRow + 1
Else
'merge if 2+ rows are included
If lngEnd - lngStart > 0 Then
Range("A" & lngStart & ":A" & lngEnd).Merge
Range("B" & lngStart & ":B" & lngEnd).Merge
Range("C" & lngStart & ":C" & lngEnd).Merge
Range("D" & lngStart & ":D" & lngEnd).Merge
End If
'reset included rows
lngStart = myRow + 1
lngEnd = myRow + 1
End If
Next myRow
Application.DisplayAlerts = True
End Sub

Resources