I have a code that builds up and selects the range to copy it over to another worksheet in another sub.
Sub SelectREZ()
'Disable screen update
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Declare variables
Dim c As Range, ws As Worksheet
Dim rngG As Range, lastJ, rngJ As Range
Set ws = ActiveSheet
For Each c In Intersect(ws.UsedRange, ws.Columns("C"))
Set rngJ = c.EntireRow.Columns("J")
If c = "REZ" Then
AddRange rngG, c.EntireRow
'Remember the "ITEM NO."
lastJ = rngJ.Value
Else
If Len(lastJ) > 0 Then
If rngJ.Value Like lastJ & "*" Then
AddRange rngG, c.EntireRow
Else
lastJ = ""
End If
End If
End If
Next c
rngG.Select
End Sub
'Utility sub for building up a range
Sub AddRange(rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
'Disable screen update
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
And I've ran into a situation when the range is empty and macro dies on the line
rngG.Select
How do I prevent such macro crash and quit the sub if range to select is empty?
I mean I could do:
On Error Resume Next
rngG.Select
But it seems like a sledgehammer way to approach it.
Related
I have been trying to format cells in different rows one with number and another with date using VBA . My code is as below. But the second event is not getting triggered. When I interchange the 1s and 2nd event up to down (date first and number second), date format works and number doesn't works. Can I get any help here please?
*Private Sub Worksheet_Change(ByVal Target As Range)
'___________ 8 DIGITS FORMAT ____________________
Dim i As Integer
Dim cell As Integer
Application.EnableEvents = False
On Error GoTo Err 'To avoid error when multiple cells are selected
If Not Intersect(Target, Range("U:U")) Is Nothing Or _
Not Intersect(Target, Range("B:B")) And Target.Value <> "" Then
cell = Target.Rows.Count
For i = 1 To cell
'To avoid cells with NO VALUE to be FORMATTED
If Target.Cells(i, 1).Value <> "" Then
Target.Cells(i, 1).NumberFormat = "#"
Target.Cells(i, 1).Value = Application.WorksheetFunction.Text(Target.Cells(i, 1).Value, "00000000")
Else
Resume LetsContinue
End If
Next i
End If
Application.EnableEvents = True
'______________________ Date Format ____________________
Dim x As Integer
Dim dt As Integer
Application.EnableEvents = False
On Error GoTo Err2 'To avoid error when multiple cells are selected
If Not Intersect(Target, Range("E:E")) Is Nothing Or _
Not Intersect(Target, Range("AQ:AQ")) And Target.Value <> "" Then
dt = Target.Rows.Count
For x = 1 To dt
'To avoid cells with NO VALUE to be FORMATTED
If Target.Cells(x, 1).Value <> "" Then
Target.Cells(x, 1).NumberFormat = "dd-Mmm-yyyy"
Target.Cells(x, 1).Value = Application.WorksheetFunction.Text(Target.Cells(x, 1).Value, "dd-Mmm-yyyy")
Else
Resume LetsContinue
End If
Next x
Else
End If
Application.EnableEvents = True
Err:
If Not Intersect(Target, Range("U:U")) Is Nothing Or Not Intersect(Target, Range("B:B")) Is Nothing Then
Resume Next
Else
Resume LetsContinue
End If
Err2:
If Not Intersect(Target, Range("E:E")) Is Nothing Or Not Intersect(Target, Range("AQ:AQ")) Is Nothing Then
Resume Next
Else
Resume LetsContinue
End If
LetsContinue:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
Whoa:
Resume LetsContinue
End Sub*
A Worksheet Change: Formats and Values in Multiple Columns
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rg As Range
Dim irg As Range
' 8 digits
Set rg = RefColumns(Me, 2, "B,U")
Set irg = Intersect(rg, Target)
If Not irg Is Nothing Then
Format8Digits irg
Set irg = Nothing
End If
' Dates
Set rg = RefColumns(Me, 2, "E,AQ")
Set irg = Intersect(rg, Target)
If Not irg Is Nothing Then
FormatDates irg
Set irg = Nothing
End If
End Sub
Function RefColumns( _
ByVal ws As Worksheet, _
ByVal FirstRow As Long, _
ByVal ColumnsList As String, _
Optional ByVal Delimiter As String = ",") _
As Range
Dim Cols() As String: Cols = Split(ColumnsList, ",")
Dim rResize As Long: rResize = ws.Rows.Count - FirstRow + 1
Dim trg As Range
Dim rg As Range
Dim n As Long
For n = 0 To UBound(Cols)
Set rg = ws.Cells(FirstRow, Cols(n)).Resize(rResize)
If trg Is Nothing Then Set trg = rg Else Set trg = Union(trg, rg)
Next n
Set RefColumns = trg
End Function
Sub Format8Digits(ByVal rg As Range)
On Error GoTo ClearError
Application.EnableEvents = False
Dim Cell As Range
For Each Cell In rg.Cells
If Len(CStr(Cell.Value)) > 0 Then
Cell.NumberFormat = "#"
Cell.Value = Application.WorksheetFunction _
.Text(Cell.Value, "00000000")
End If
Next Cell
SafeExit:
Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
Sub FormatDates(ByVal rg As Range)
On Error GoTo ClearError
Application.EnableEvents = False
Dim Cell As Range
For Each Cell In rg.Cells
If IsDate(Cell) Then
Cell.NumberFormat = "dd-Mmm-yyyy"
Cell.Value = Application.WorksheetFunction _
.Text(Cell.Value, "dd-Mmm-yyyy")
End If
Next Cell
SafeExit:
Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
I found solution for this query after 2 months.
In the first event when we give Resume LetsContinue which actually ends the code, 2nd event should be triggered for which 2nd and subsequent events should be given defined with names and Resume "Events" in 1st event.
Here is how it should be:
Resume Event2
End If
Next i
End If
Application.EnableEvents = True
'______________________ Date Format ____________________
Event2:
Dim x As Integer
Dim dt As Integer
Application.EnableEvents = False
On Error GoTo Err2 'To avoid error when multiple cells are selected
If Not Intersect(Target, Range("E:E")) Is Nothing Or _
Not Intersect(Target, Range("AQ:AQ")) And Target.Value <> "" Then
dt = Target.Rows.Count
And the code continues----------------
I am working on a project to clean up a couple hundred excel sheets for an specific import spec. The import process errors out if any rows have a specific value blank, so I'm looking to find the best way to delete all rows in the entire workbook if column C in that row is empty. I found this simple VBA code that works on the active sheet, but I need it to loop through all sheets in the workbook. Any suggestions on a better process so I don't have to run it >100 times?
Sub DelBlankRows()
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
Delete the Rows of a Column's Blanks
Option Explicit
Sub DelRowsOfColumnBlanksTEST()
Const wsCol As Variant = "C" ' or 3
'Const wsCol As String = "C"
'Const wsCol As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In wb.Worksheets
DelRowsOfColumnBlanks ws, wsCol
Next ws
Application.ScreenUpdating = True
End Sub
Sub DelRowsOfColumnBlanks( _
ByVal ws As Worksheet, _
ByVal WorksheetColumnID As Variant)
If ws Is Nothing Then Exit Sub ' no worksheet
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
Dim urg As Range: Set urg = ws.UsedRange
If urg.Rows.Count = 1 Then Exit Sub ' only one row
On Error Resume Next
Dim crg As Range: Set crg = ws.Columns(WorksheetColumnID)
On Error GoTo 0
If crg Is Nothing Then Exit Sub ' invalid Worksheet Column ID
Dim tcrg As Range: Set tcrg = Intersect(urg, crg)
' ... is only the same as 'Set tcrg = urg.Columns(WorkhseetColumnID)',...
' ... if the first column of the used range is column 'A'.
If tcrg Is Nothing Then Exit Sub ' no intersection
Dim drg As Range: Set drg = tcrg.Resize(tcrg.Rows.Count - 1).Offset(1)
tcrg.AutoFilter 1, "=" ' ... covers blanks: 'Empty', "=""""", "'"... etc.
' Note that although it contains the word 'Blanks',...
' ... 'SpecialCells(xlCellTypeBlanks)' only covers 'Empty'.
On Error Resume Next
Dim spcrg As Range: Set spcrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not spcrg Is Nothing Then
spcrg.EntireRow.Delete
'Else
' no 'visible' cells (to delete)
End If
ws.AutoFilterMode = False
End Sub
Option Explicit
Sub CleanWorkbook()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
DeleteRowsOfEmptyColumn sh, "C"
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub DeleteRowsOfEmptyColumn(sh As Worksheet, col as string)
Dim rowsToDelete As New Collection
Dim cell
For Each cell In Intersect(sh.UsedRange, sh.Columns(col))
If cell.Value = "" Then
rowsToDelete.Add cell.Row
End If
Next
Dim i As Integer
For i = rowsToDelete.Count To 1 Step -1
sh.Rows(rowsToDelete(i)).Delete
Next
End Sub
I've put a very basic error trap for any sheets with no values in C. You may need to improve this yourself.
Edit: Updated error trap
Sub DelBlankRows()
Dim sh As Worksheet
Application.ScreenUpdating = False
On Error GoTo Handle
For Each sh In ThisWorkbook.Worksheets
sh.Activate
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Cont:
Next sh
Application.ScreenUpdating = True
Exit Sub
Handle:
If Err.Number = 1004 Then Resume Cont
End Sub
I am new to VBA and this is the first Macro I've tried to write.
I have an excel table which has five columns titled Address, location , works , action and completed. I want to create a new worksheet for each unique address and then copy the relevant rows for that address on that new worksheet. However, I only want to copy and paste the unique rows if the value in "Completed" is "N". The Value in completed can only be "Y" or "N".
Here is the code I have written:
Dim AddressField As Range
Dim AddressName As Range
Dim CompletedField As Range
Dim NewWSheet As Worksheet
Dim WSheet As Worksheet
Dim WSheetFound As Boolean
Dim DataWSheet As Worksheet
Set DataWSheet = Worksheets("Data")
Set AddressField = DataWSheet.Range("A4", DataWSheet.Range("A4").End(xlDown))
Set CompletedField = DataWSheet.Range("E4", DataWSheet.Range("E4").End(xlDown))
Application.ScreenUpdating = False
For Each AddressName In AddressField
For Each WSheet In ThisWorkbook.Worksheets
If CompletedField = "No" Then
If WSheet.Name = AddressName Then
WSheetFound = True
Exit For
Else
WSheetFound = False ' if it doesn't assign False to the WSheetFound variable
End If
Next WSheet
If WSheetFound Then 'if WSheetFound = True
AddressName.Offset(0, 0).Resize(1, 5).Copy Destination:=Worksheets(AddressName.Value).Range("A3").End(xlDown).Offset(1, 0)
Else 'if WSheetFound = False
Set NewWSheet = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
NewWSheet.Name = AddressName
DataWSheet.Range("A3", DataWSheet.Range("A3").End(xlToRight)).Copy Destination:=NewWSheet.Range("A3")
AddressName.Offset(0, 0).Resize(1, 5).Copy Destination:=NewWSheet.Range("A4")
End If
Next AddressName
For Each WSheet In ThisWorkbook.Worksheets
WSheet.UsedRange.Columns.AutoFit
Next WSheet
Application.ScreenUpdating = True
End Sub
I keep getting the "Next without For" error when I try to run the code. I think it has something to do with the "IF CompletedField = "N" line, but not sure how to fix it !
Any help would be greatly appreciated
Try this:
Sub CopyRows()
Dim c As Range, ws As Worksheet, DataWSheet As Worksheet, wb As Workbook
Set wb = ThisWorkbook
Set DataWSheet = wb.Worksheets("Data")
Application.ScreenUpdating = False
For Each c In DataWSheet.Range("A4", DataWSheet.Range("A4").End(xlDown)).Cells
If c.EntireRow.Columns("E").Value = "No" Then
Set ws = Nothing
On Error Resume Next 'ignore any error on next line
Set ws = wb.Worksheets(c.Value) 'try to get the sheet
On Error GoTo 0 'stop ignoring errors
If ws Is Nothing Then 'was sheet found?
Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
DataWSheet.Rows(3).Copy ws.Range("A3") 'copy headers
ws.Name = c.Value 'name the sheet
End If
c.Resize(1, 5).Copy ws.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next c
For Each ws In wb.Worksheets
ws.UsedRange.Columns.AutoFit
Next ws
Application.ScreenUpdating = True
End Sub
Check the Completed column before deciding if a sheet needs to be created or not.
Update - Added copy for A1,A2,D2
Sub test()
Dim AddressField As Range, AddressName As Range, CompletedField As Range
Dim NewWSheet As Worksheet, WSheet As Worksheet, DataWSheet As Worksheet
Dim WSheetFound As Boolean
Set DataWSheet = Worksheets("Data")
Set AddressField = DataWSheet.Range("A4", DataWSheet.Range("A4").End(xlDown))
'Set CompletedField = DataWSheet.Range("E4", DataWSheet.Range("E4").End(xlDown))
Application.ScreenUpdating = False
For Each AddressName In AddressField
If AddressName.Cells(1, 5) = "No" Then ' col E
For Each WSheet In ThisWorkbook.Worksheets
If WSheet.Name = AddressName.Value2 Then
WSheetFound = True
Exit For
Else
WSheetFound = False ' if it doesn't assign False to the WSheetFound variable
End If
Next WSheet
If WSheetFound Then 'if WSheetFound = True
AddressName.Offset(0, 0).Resize(1, 5).Copy _
Destination:=Worksheets(AddressName.Value).Range("A3").End(xlDown).Offset(1, 0)
Else 'if WSheetFound = False
Set NewWSheet = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
NewWSheet.Name = AddressName
DataWSheet.Range("A1:A2").Copy NewWSheet.Range("A1")
DataWSheet.Range("D2").Copy NewWSheet.Range("D2")
DataWSheet.Range("A3", DataWSheet.Range("A3").End(xlToRight)).Copy _
Destination:=NewWSheet.Range("A3")
AddressName.Offset(0, 0).Resize(1, 5).Copy Destination:=NewWSheet.Range("A4")
End If
End If
Next AddressName
For Each WSheet In ThisWorkbook.Worksheets
WSheet.UsedRange.Columns.AutoFit
Next WSheet
Application.ScreenUpdating = True
End Sub
I have some code here but I'd like it to skip worksheets names Aggregated, Collated Results, Template, End. I have tried to add an If statement in to skip these but it doesn't seem to like it.
Sub FillBlanks()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
For Each ws In Worksheets
Set rng2 = ws.Range("L1:AB40")
On Error Resume Next
Set rng1 = rng2.SpecialCells(xlBlanks)
on error goto 0
if not rng1 is nothing then
Application.Iteration = True
rng1.FormulaR1C1 = "=AVERAGE(R[-1]C,R[1]C)"
Application.Iteration = False
rng2.Value = rng2.Value
end if
Next ws
End Sub
If you add the names of the sheets you want to skip to the line worksheetsToSkip = array("... (below), then the code below should skip said sheets.
Option Explicit
Sub FillBlanks()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim worksheetsToSkip As Variant
worksheetsToSkip = Array("Aggregated", "Collated Results", "Template", "End")
For Each ws In Worksheets
If IsError(Application.Match(ws.Name, worksheetsToSkip, 0)) Then
Set rng2 = ws.Range("L1:AB40")
On Error Resume Next
Set rng1 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng1 Is Nothing Then
Application.Iteration = True
rng1.FormulaR1C1 = "=AVERAGE(R[-1]C,R[1]C)"
Application.Iteration = False
rng2.Value = rng2.Value
End If
End If
Next ws
End Sub
How can I change this code so it runs on all sheets of a workbook? It works well, just need it to run on all sheets. =)
Option Explicit
Option Compare Text
Sub HideColumns()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Data")
Dim MyCell As Range
Dim HideMe As Range
Application.ScreenUpdating = False
For Each MyCell In ws.Range("A2:EA2")
If MyCell <> "First Name" And MyCell <> "Age" And MyCell <> "Gender" Then
If HideMe Is Nothing Then
Set HideMe = MyCell
Else
Set HideMe = Union(HideMe, MyCell)
End If
End If
Next MyCell
If Not HideMe Is Nothing Then
HideMe.EntireColumn.Hidden = True
End If
Application.ScreenUpdating = True
End Sub
Loop through sheets using For Each loop & reset HideMe to Nothing before moving to next sheet.
Option Explicit
Option Compare Text
Sub HideColumns()
Dim ws As Worksheet 'Change made here
Dim MyCell As Range
Dim HideMe As Range
Application.ScreenUpdating = False
For Each ws in Worksheets 'and here
For Each MyCell In ws.Range("A2:EA2")
If MyCell <> "First Name" And MyCell <> "Age" And MyCell <> "Gender" Then
If HideMe Is Nothing Then
Set HideMe = MyCell
Else
Set HideMe = Union(HideMe, MyCell)
End If
End If
Next MyCell
If Not HideMe Is Nothing Then
HideMe.EntireColumn.Hidden = True
End If
Set HideMe = Nothing 'and here
Next ws 'and here
Application.ScreenUpdating = True
End Sub