I would like to with this macro delete all cells after last empty row until the line where in column "E" is "Total"
I've tried this, but there is error on loop line:
Sub delete()
Dim r As Range
Dim lastRow As Long
Dim c As Range
Dim i As Long
i = lastRow + 1
With ThisWorkbook.Worksheets("Sheet1")
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Do
Set r = Range("B" & i)
If Len(r) = 0 Then r.EntireRow.delete
i = i + 1
Loop Until Cells(i, 5).Value = "Total"
End Sub
And here is the example how my table look like:
I'd use something like the following which will continue through all cells until E&i = total:
Public Sub Delete()
Dim i As Long
i = 2 'Start from row 2
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
Do Until .Range("E" & i).Value = "Total"
If .Range("B" & i).Value = vbNullString 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
Related
can anyone advise how can I turn RowIncrement = 2 into a "loop" that goes and pick ups the values from a column based on the other sheet? So, if the first value in the column is 1 then RowIncrement = 1, then it goes to the next value in that column, which may be e.g. 6 and then RowIncrement = 6 and so on.
Sub EmptyRowEveryX()
Dim NumRowsToInsert As Long
Dim RowIncrement As Long
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim LastEvenlyDivisibleRow
Dim i As Long
Dim z As Long
Dim HowMany As Integer
NumRowsToInsert = 1
RowIncrement = 2
Set ws = ActiveSheet
For n = LastRow To 1 Step -1
HowMany = Range("BM" & z)
If (HowMany > 1) Then
Rows(z & ":" & HowMany).Insert Shift:=xlDown
End If
With ws
LastRow = .Range("AZ" & .Rows.count).End(xlUp).Row
LastEvenlyDivisibleRow = Int(LastRow / RowIncrement) * RowIncrement
If LastEvenlyDivisibleRow = 0 Then
Exit Sub
End If
For i = LastEvenlyDivisibleRow To 1 Step -RowIncrement
.Range(i & ":" & i + (NumRowsToInsert - 1)).Insert xlShiftDown
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub OneEmptyRow()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Range("AZ1", Range("AZ" & Rows.count).End(xlUp))
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
.Offset(, -1).AutoFilter Field:=1, Criteria1:="=*total*"
.Offset(2).SpecialCells(xlCellTypeVisible).ClearContents
.AutoFilter
.Offset(, -1).EntireColumn.Delete
.EntireColumn.RemoveSubtotal
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
My function is always returning 0 when called in a worksheet but returns proper values when called through a sub.
This function searches through a worksheet (sheetname) to see if the input value can be found in any of the columns, and if so returns the value in row 1 of the column.
'test sub
Sub test()
MsgBox custCat("SUNTRUST BANK")
End Sub
Public Function custCat(toSearch)
Dim sheetName As String
sheetName = "LookupValues"
Dim i As Integer
i = 1
Dim lastRow As Integer
Dim colLtr As String
Dim j As Integer
'find last column
Dim lastColumn As Integer
lastColumn = Worksheets(sheetName).Range("A1").SpecialCells(xlCellTypeLastCell).Column
'loop through columns
Do While i <= lastColumn
'find last row
lastRow = Worksheets(sheetName).Cells(Worksheets(sheetName).Rows.Count, i).End(xlUp).Row
'search through column
j = 2
Do While j <= lastRow
If InStr(UCase(toSearch), UCase(Worksheets(sheetName).Cells(j, i).Value)) > 0 Then
If custCat = "" Then
custCat = Worksheets(sheetName).Cells(1, i).Value
Else
custCat = custCat & ", " & Worksheets(sheetName).Cells(1, i).Value
End If
j = lastRow 'exit loop if found
End If
j = j + 1
Loop
i = i + 1
Loop
End Function
I cleaned up the code a bit and made a few adjustments, try this:
Public Function custCat(toSearch)
Dim i&, j&, lastRow&, lastColumn&
Dim ws As Worksheet
Set ws = Worksheets("LookupValues")
With ws
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
i = 1
'loop through columns
Do While i <= lastColumn
'find last row
lastRow = .Cells(.Rows.Count, i).End(xlUp).Row
'search through column
j = 2
Do While j <= lastRow
If InStr(UCase(toSearch), UCase(.Cells(j, i).Value)) > 0 Then
If custCat = "" Then
custCat = .Cells(1, i).Value
Else
custCat = custCat & ", " & .Cells(1, i).Value
End If
Exit Do 'exit loop if found
End If
j = j + 1
Loop
i = i + 1
Loop
End With
End Function
Why does the following VBA script not show any message boxes when row 4, 5 and 6 are all empty...
Sub Test()
LastRow = 40
For i = LastRow To 3 Step -1
Set myRange = Range("B" & i & ":T" & i)
If WorksheetFunction.CountA(myRange) = 0 Then
MsgBox "Empty " & Cells(i, 1).Row
Else
x = x
End If
Next
End Sub
Just test both column ranges:
Sub Test()
LastRow = 40
For i = LastRow To 3 Step -1
count = WorksheetFunction.CountA(Range("B"&i & ":D"&i))
count = count + WorksheetFunction.CountA(Range("F"&i & ":T"&i))
If count = 0 Then
MsgBox "Empty " & i
End If
Next
End Sub
edit: or build a range object which contains the two column ranges, intersect that with the last row, and move this range object in the loop. This way, you don't build the range object anew in each iteration:
Sub Test()
Dim rng As Range, colrng As Range
Dim LastRow As Long
Dim i As Long
LastRow = 40
Set colrng = Application.Union(Range("B:D"), Range("F:T"))
Set rng = Application.Intersect(colrng, Rows(LastRow))
For i = LastRow To 3 Step -1
If WorksheetFunction.CountA(rng) = 0 Then
MsgBox "Empty row: " & i
End If
Set rng = rng.Offset(-1, 0)
Next
End Sub
As good practice, always declare your variables, and use long integers for row or column indices.
Sub Test()
LastRow = 40
For i = LastRow To 3 Step -1
Set myRange = Range("B" & i & ":T" & i)
If WorksheetFunction.CountIf(myRange,"<>") = 0 Then 'count where it's not a null or empty string
MsgBox "Empty " & Cells(i, 1).Row
Else
x = x
End If
Next
End Sub
The only way I can seem to do it is a slow way:
LastRow = Range("B:Z").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
For i = LastRow To 3 Step -1
BlankRow = False
For j = 2 To LastColumn
If Cells(i, j).Value <> "" Then
Blank = False
Exit For
End If
BlankRow = True
Next j
If BlankRow = True Then
x = x
End If
Next i
I've got a sheet set up to get the contents of the last row. I want to check the values on that last row from J to W. I want to check if all the values are "YES" and if so return an OK into a variable. Here is what I have so far, it should be clear from the below what I am trying to do:
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
sName = ActiveSheet.Name
For Each c In Worksheets(sName).Range(Cells(J, lastRow), Cells(W, lastRow))
If c.Value = "YES" Then
vData = "OK"
Else
vData = "Error."
End If
Next c
Thanks.
Cells(x,y) takes two integers as arguments, and it's row, column not column, row!
Try
For Each c In Sheets(sName).Range(Cells(lastRow, 10), Cells(lastRow, 23))
Dim lRow As Long
Dim lCol As Long
Dim ws As Excel.Worksheet
Set ws = Application.ActiveSheet
lRow = ws.UsedRange.Rows.count
lCol = 10
Do While lCol <= 21
If ws.Cells(lRow, lCol).Value <> "YES" Then
vData = "Error."
Exit Sub
End If
lCol = lCol + 1
Loop
Try this one:
Public Sub checking()
Dim lastRow As Long
'Here, I take row count by using column "J"
'You can modify it if you need
lastRow = Sheets("sheetname").Range("J" & Rows.Count).End(xlUp).row
For Each cell In Sheets("sheetname").Range("J" & lastRow & ":W" & lastRow)
If cell.Value = "YES" Then
vData = "OK"
Else
vData = "Error."
Exit For
End If
Next cell
'Show result
MsgBox vData
End Sub
I have a workbook that has 2 worksheets and sub-sheets Named as per Product Line Column:
NEW DATA sheet
Master Table sheet ("DBQ Query Result")
Subsheets (Driling and Workover, Fishing, Liner Systems, Professional Services, Wellbore Cleaning)
They both have same headers, within the column headers there is a uniqueID column.
PART A
I would like to match uniqueID between those 2 sheets and:
When there is a match, compare row cell values for each column and update if there is difference
When there is a uniqueID in NEW DATA sheet that does not exist in Master Table, I would like this whole row associated to this uniqueId to be copied to Master Table sheet
PART B
I would like to have a new button that when pressed, UniqueID from Master Page will be compared with Unique Id column of each subsheet and:
When there is a match, update subsheet row according to UNIQUEID
When there is no match, that means a new UNIQUEID is created and this should be added to its corresponding subsheet as a last row
I would like to accomplish the above using VBA macro please. I have attached a sample of the excel https://dl.dropboxusercontent.com/u/29585269/Sample.xlsx.
Please let me know if you need any additional information.
I came across few codes online and modified them to fit my need.
So, this is how it goes:
You have 3 Main Sheets next to your PL Sheets - Subsheets (Driling and Workover, Fishing, Liner Systems, Professional Services, Wellbore Cleaning):
Original
Updated
Changes
This code will print the changes between Original Sheet and Updated Sheet:
Option Explicit
Sub CompareSheets()
'
' constants
' worksheets & ranges
' original
Const ksWSOriginal = "ORIGINAL"
Const ksOriginal = "OriginalTable"
Const ksOriginalKey = "OriginalKey"
' updated
Const ksWSUpdated = "UPDATED"
Const ksUpdated = "UpdatedTable"
Const ksUpdatedKey = "UpdatedKey"
' changes
Const ksWSChanges = "CHANGES"
Const ksChanges = "ChangesTable"
' labels
Const ksChange = "CHANGE"
Const ksRemove = "REMOVE"
Const ksAdd = "ADD"
'
' declarations
Dim rngO As Range, rngOK As Range, rngU As Range, rngUK As Range, rngC As Range
Dim c As Range
Dim I As Long, J As Long, lChanges As Long, lRow As Long, bEqual As Boolean
'
' start
Set rngO = Worksheets(ksWSOriginal).Range(ksOriginal)
Set rngOK = Worksheets(ksWSOriginal).Range(ksOriginalKey)
Set rngU = Worksheets(ksWSUpdated).Range(ksUpdated)
Set rngUK = Worksheets(ksWSUpdated).Range(ksUpdatedKey)
Set rngC = Worksheets(ksWSChanges).Range(ksChanges)
With rngC
If .Rows.Count > 1 Then
Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
Range(.Rows(2), .Rows(.Rows.Count)).Font.ColorIndex = xlColorIndexAutomatic
Range(.Rows(2), .Rows(.Rows.Count)).Font.Bold = False
End If
End With
'
' process
lChanges = 1
' 1st pass: updates & deletions
With rngOK
For I = 5 To .Rows.Count
Set c = rngUK.Find(.Cells(I, 1).Value, , xlValues, xlWhole)
If c Is Nothing Then
' deletion
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksRemove
For J = 1 To rngO.Columns.Count
rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbRed
rngC.Cells(lChanges, J + 1).Font.Bold = True
Next J
Else
bEqual = True
lRow = c.Row - rngUK.Row + 1
For J = 1 To rngO.Columns.Count
If rngO.Cells(I, J).Value <> rngU.Cells(lRow, J).Value Then
bEqual = False
Exit For
End If
Next J
If Not bEqual Then
' change
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksChange
For J = 1 To rngO.Columns.Count
If rngO.Cells(I, J).Value = rngU.Cells(lRow, J).Value Then
rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
Else
rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbMagenta
rngC.Cells(lChanges, J + 1).Font.Bold = True
End If
Next J
End If
End If
Next I
End With
' 2nd pass: additions
With rngUK
For I = 5 To .Rows.Count
Set c = rngOK.Find(.Cells(I, 1).Value, , xlValues, xlWhole)
If c Is Nothing Then
' addition
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksAdd
For J = 1 To rngU.Columns.Count
rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbBlue
rngC.Cells(lChanges, J + 1).Font.Bold = True
Next J
End If
Next I
End With
'
' end
Worksheets(ksWSChanges).Activate
rngC.Cells(2, 3).Select
Set rngC = Nothing
Set rngUK = Nothing
Set rngU = Nothing
Set rngOK = Nothing
Set rngO = Nothing
Beep
'
End Sub
This Button Code will Apply Updates to rows noted as "Changes" and "Add" (I dont care about Remove)
Sub Update()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim tempName As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
Application.ScreenUpdating = False
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL")
Set sh2 = ActiveWorkbook.Worksheets("CHANGES")
lastRow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Get last row for both sheets
lastRow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row ' searching both
For s2Row = 2 To lastRow2 'Loop through "CHANGES"
If sh2.Cells(s2Row, 1).Value = "CHANGE" Then
tempName = sh2.Cells(s2Row, 2).Value 'extra step for understanding concept
'There is a match, so now
For s1Row = 2 To lastRow1 'Search through the other sheet
If sh1.Cells(s1Row, 1).Value = tempName Then
For I = 2 To 35
sh1.Cells(s1Row, I).Value = sh2.Cells(s2Row, I + 1).Value 'Copy Values
Next I
End If
Next s1Row
End If
Next s2Row
For s2Row = 2 To lastRow2
If sh2.Cells(s2Row, 1).Value = "ADD" Then
sh2.Range("B" & s2Row & ":BB" & s2Row).Copy 'Copy rows
sh1.Rows(lastRow1 + 1).Insert Shift:=xlDown 'Insert rows
sh1.Cells(lastRow1 + 1, 78).Value = "ADD" 'Classify the row as newly added
End If
Next s2Row
Application.ScreenUpdating = True
Sheets("ORIGINAL").Activate
End Sub
And this button will apply updates to PL Cell Values for existing UniqueIDs changes
Sub Update_PL()
Dim ws As Worksheet
Dim lastRng As Range
Application.ScreenUpdating = False 'speed up code
'Added to loop through all UniqueIDs and update accordingly
Dim sh1 As Worksheet, sh2 As Worksheet
Dim tempName As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
'No Longer requires clearing screen, we will match unique ids and update/add as necessary
'ThisWorkbook.Sheets("ORIGINAL").Rows("5:65536").ClearContents 'clear
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL") 'Define Master Table
Set sh2 = ws 'Selects Active Sheet
For Each ws In ThisWorkbook.Worksheets
Set lastRng = ThisWorkbook.Sheets("ORIGINAL").Range("A65536").End(xlUp).Offset(1, 0)
Select Case ws.Name
Case "ORIGINAL" 'exlude
Case "UPDATED" 'exlude
Case "CHANGES" 'exlude
Case "Report Table" 'exlude
Case "DASHBOARD" 'exlude
'do nothing
Case Else
ws.Activate
lastRow2 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Count Master Table Rows to extract Last Row #
With ActiveSheet
lastRow1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Count Active Sheet Rows to extract Last Row #
End With
For s2Row = 2 To lastRow2 'Loop through Active WorkSheet
tempName = sh1.Cells(s2Row, 1).Value 'Define UniqueID to loop
tempPL = sh1.Cells(s2Row, 22).Value 'Define PL to loop
For s1Row = 2 To lastRow1 'Match UniqueIDs between Master sheet and Active Sheet
If ActiveSheet.Cells(s1Row, 1).Value = tempName Then 'If Matches TRUE then
For I = 2 To 35 'Loop all Columns and update as necessary
ActiveSheet.Cells(s1Row, I).Value = sh1.Cells(s2Row, I).Value 'Copy Values
Next I
End If
Next s1Row
Next s2Row
'copy data from individual sheets
'Range("A2", Range("AB65536").End(xlUp)).Copy lastRng
End Select
Next
Application.CutCopyMode = False 'clear clipboard
Application.ScreenUpdating = True
Sheets("ORIGINAL").Activate
End Sub
And this last button is used to Add new UniqueIDs to corresponding PL
Sub Add_Rows()
Dim ws As Worksheet
Dim lastRng As Range
Application.ScreenUpdating = False 'speed up code
'Added to loop through all UniqueIDs and update accordingly
Dim sh1 As Worksheet
Dim tempPL As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL") 'Define Master Table
For Each ws In ThisWorkbook.Worksheets
Set lastRng = ThisWorkbook.Sheets("ORIGINAL").Range("A65536").End(xlUp).Offset(1, 0)
Select Case ws.Name
Case "ORIGINAL" 'exlude
Case "UPDATED" 'exlude
Case "CHANGES" 'exlude
Case "Report Table" 'exlude
Case "DASHBOARD" 'exlude
'do nothing
Case Else
ws.Activate
lastRow2 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Count Master Table Rows to extract Last Row #
With ActiveSheet
lastRow1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Count Active Sheet Rows to extract Last Row #
End With
For s2Row = 5 To lastRow2 'Loop through Active WorkSheet
If sh1.Cells(s2Row, 78).Value = "ADD" Then
tempPL = sh1.Cells(s2Row, 23).Value
If ActiveSheet.Name = tempPL Then
sh1.Range("A" & s2Row & ":AB" & s2Row).Copy 'Copy rows
ActiveSheet.Rows(lastRow1 + 1).Insert Shift:=xlDown 'Insert rows
sh1.Cells(s2Row, 78).Value = "ADDED" 'Validate Row has been added in Master Sheet
End If
End If
Next s2Row
End Select
Next
Application.CutCopyMode = False 'clear clipboard
Application.ScreenUpdating = True 'Resume ScreenUpdating
Sheets("ORIGINAL").Activate 'Display Original Sheet
End Sub
Complicated? Yeah... but solved my issue.
BR! Eddy