I have a list called "District List" on one tab and a Template that is driven by putting the name of a district into Cell C3. Each District has a wildly varying number of branches (between 1 & 500+ branches depending on the District) so the report template has a lot of blank space in some cases. I came up with this to loop through the District List, copy the Template tab, rename it the District Name, insert the name of the district into Cell C3, and then I have another loop to hide the blank rows.
It works, but it takes forever, like 5 minutes per tab, then after about four tabs, I get an object error at the first like of Sub CreateTabsFromList.
Is there a problem with the code, or is this just a really inefficient way to do this? If so can anyone help with a better method?
Sub HideRows()
Dim r As Range, c As Range
Set r = Range("a1:a1000") 'Sets range well beyond the last possible row with data
Application.ScreenUpdating = False
For Each c In r
If Len(c.Text) = 0 Then
c.EntireRow.Hidden = True 'Hide the row if the cell in A is blank
Else
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
Sub CreateSheetsFromAList()
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("District List").Range("A1")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
For Each MyCell In MyRange
Sheets("Template").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
Range("C3").Value = MyCell.Value 'Pastes value in C3
Sheets(Sheets.Count).Name = MyCell.Value 'renames worksheet
HideRows 'Hides rows where cell in column A is ""
Next MyCell
End Sub
Deleting/Hiding rows, 1 by 1 is the slowest method. Always club them in one range and delete/hide them in one go, also looping through cells is slower than looping array.
Sub HideRows()
Dim lCtr As Long
Dim rngDel As Range
Dim r As Range
Dim arr
Set r = Range("a1:a1000") 'Sets range well beyond the last possible row with data
Application.ScreenUpdating = False
arr = r
For lCtr = LBound(arr) To UBound(arr)
If arr(lCtr, 1) = "" Then
If rngDel Is Nothing Then
Set rngDel = Cells(lCtr, 1) 'harcoded 1 as you are using column A
Else
Set rngDel = Union(rngDel, Cells(lCtr, 1))
End If
End If
Next
If Not rngDel Is Nothing Then
rngDel.EntireRow.Hidden=True
End If
Application.ScreenUpdating = True
End Sub
takes fraction of a second for 1000 rows.
Related
Apologies if this has been answered before, I'm unable to find anything that matches my specific case.
I have a workbook with 18 sheets, and a variable number of columns per sheet starting at B2. Occasionally the program that generates the sheet will create duplicate columns, due to this, I need a macro triggered by button to search each sheet for matching column headers and then delete one of these columns (the whole column, not just the header).
So far I'm pretty stuck, I've been able to delete all matches from any cell in the sheet, which pretty much wipes the entire sheet out. I just need to match headers and then delete the entire column based on that.
Let me know if you need any more information, and thank you for the help!
What I have so far, the code is doing some other stuff too so this needs to continue working.
Sub RemoveExtras()
Dim MyRange As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
BadCharacters = Array(Chr(10), Chr(13))
wsNumber = Sheets.Count
For Each ws In Worksheets
With ws
For Each MyRange In .UsedRange
If 0 < InStr(MyRange, Chr(10)) Then
For Each i In BadCharacters
MyRange = Replace(MyRange, i, vbNullString)
Next i
End If
For t = 1 To wsNumber
Columns(t).RemoveDuplicates Columns:=Array(1), Header:=xlYes
Next t
Next MyRange
End With
Next ws
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Dictionaries are perfect for handling unique values:
Sub RemoveExtras()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim c As Integer, i As Integer, ws As Worksheet
Dim dict As Object
For Each ws In Worksheets
Set dict = CreateObject("Scripting.Dictionary")
'Find Last column
c = ws.UsedRange.Columns.Count
'Loop backwards
For i = c To 2 Step -1
'If column does not exist in dictionary, then add it
If Not dict.Exists(ws.Cells(2, i).Value) Then
dict.Add ws.Cells(2, i).Value, 1
Else
'Otherwise delete column
ws.Columns(i).Delete Shift:=xlToLeft
End If
Next i
Set dict = Nothing
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Here you do not compare every pair of column headers in the sheet. Also this compares headers across all the worksheets, not just duplicates inside one individual sheet.
See if this helps you
Sub test()
Dim book As Workbook, sheet As Worksheet, text As String
For Each sheet In Worksheets
Set MR = Range("B2:Z2") 'change Z2 as per your requirement
For Each cell In MR
Set BR = Range("B2:Z2") 'change Z2 as per your requirement
For Each cell2 In BR
If cell.Value = cell2.Value Then cell.EntireColumn.Delete
Next
Next
Next sheet
End Sub
I have been struggling with this for a few hours and think it's probably time to ask for help.
I have hundreds of spreadsheets that I would like to manually open and then simplify using a macro. Each spreadsheet has a list of hospitals (approx 400) and I would like to limit each one to only showing data about 100 hospitals. The hospitals are identified by a three letter acronym in a column that varies in location (row/column) but is always titled "Code".
So, for example, I would like the macro to delete all rows that do not contain the values "Code", "ABC", "DEF", "GEH", etc.
I am not a regular Excel user and only need to use it to solve this one problem...!
I have tried the code attached but it has a couple of bugs:
It deletes rows that contain "ABC" as well. This problem goes away if I define Range("B1:B100") but not if the range extends across multiple columns (e.g. "A1:E100"). Frustratingly the "Code" column varies across the spreadsheets.
As I want to save 100 hospital codes, it feels as if there ought to be a better way than using the "Or" operator 100 times.
Can anyone help?
Sub Clean()
Dim c As Range
Dim MyRange As Range
LastRow = Cells(Cells.Rows.Count, "D").End(xlUp).Row
Set MyRange = Range("A1:E100")
For Each c In MyRange
If c.Value = "Code" Then
c.EntireRow.Interior.Color = xlNone
ElseIf c.Value = "ABC" Or c.Value = "DEF" Then
c.EntireRow.Interior.Color = vbYellow
Else
c.EntireRow.Delete
End If
Next
End Sub
Try this:
Option Explicit
Sub Clean()
Dim rngRow As Range
Dim rngCell As Range
Dim MyRange As Range
Dim blnDel As Boolean
Dim lngCount As Long
Set MyRange = Range("A1:E8")
For lngCount = MyRange.Rows.Count To 1 Step -1
blnDel = False
For Each rngCell In MyRange.Rows(lngCount).Cells
If rngCell = "ABC" Then
rngCell.EntireRow.Interior.Color = vbRed
blnDel = True
ElseIf rngCell = "DEF" Then
rngCell.EntireRow.Interior.Color = vbYellow
blnDel = True
End If
Next rngCell
If Not blnDel Then Rows(lngCount).Delete
Next lngCount
End Sub
In general, you need to loop through the rows, and then through each cell in every row. In order for the program to remember whether something should be deleted or not on a given row, between the two loops there is a blnDel, which deletes the row, if no DEF or ABC was found.
The problematic part in rows deletion in VBA, is that you should be careful to delete always the correct one. Thus, you should make a reversed loop, starting from the last row.
Option Explicit
Sub Clean()
Dim c As Range, MyRange As Range, DelRng As Range, Code As Range, CodeList As Range
Dim CodeCol As Long, LastRow As Long
''Uncomment the below. I'd put all of your codes into one sheet and then test if the value is in that range
'With CodeListSheet
' Set CodeList = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
'End With
' Update this to point at the relevant sheet
' If you're looking at multiple sheets you can loop through the sheets starting your loop here
With Sheet1
Set Code = .Cells.Find("Code")
If Not Code Is Nothing Then
CodeCol = Code.Column
LastRow = .Cells(Cells.Rows.Count, CodeCol).End(xlUp).Row
Set MyRange = .Range(.Cells(1, CodeCol), .Cells(LastRow, CodeCol))
For Each c In MyRange
If c.Value2 = "Code" Then
c.EntireRow.Interior.Color = xlNone
'' Also uncomment this one to replace your current one
'ElseIf WorksheetFunction.CountIf(CodeList, c.Value2) > 0 Then
ElseIf UCase(c.Value2) = "ABC" Or c.Value2 = "DEF" Then
c.EntireRow.Interior.Color = vbYellow
Else
If DelRng Is Nothing Then
Set DelRng = c
Else
Set DelRng = Union(DelRng, c)
End If
End If
Next c
If Not DelRng Is Nothing Then DelRng.EntireRow.Delete
Else
MsgBox "Couldn't find correct column"
Exit Sub
End If
End With
End Sub
I've written code to loop through a range for a specific value. If the value equals "123" then highlight the entire row green. However, I only want it to highlight the very first two matches it finds and stop there. Many thanks.
Sub Macro3()
Sheets("XYZ").Select
Dim rng As Range
Sheets("XYZ").Select
Set rng = Range("L2:L10000")
For Each cell In rng
If cell.Value = "123" Then
cell.EntireRow.Interior.ColorIndex = 4
End If
Next
End Sub
It's better if you avoid using Select and other relatives, instead use referenced Objects, Sheets and Ranges.
Also, you can search for the last row with data in Column L instead of just looping through row 10000.
Option Explicit
Sub Macro3()
Dim Rng As Range, cell As Range
Dim counter As Integer, LastRow As Long
With Sheets("XYZ")
' find last row at Column "L"
LastRow = .Cells(.Rows.Count, "L").End(xlUp).Row
Set Rng = .Range("L2:L" & LastRow)
For Each cell In Rng
If cell.Value = "123" Then
cell.EntireRow.Interior.ColorIndex = 4
counter = counter + 1
End If
If counter >= 2 Then Exit For
Next
End With
End Sub
Sub Macro3()
Sheets("XYZ").Select
Dim rng As Range
dim count as integer
'Set the range in column D to loop through
Sheets("XYZ").Select
Set rng = Range("L2:L10000")
For Each cell In rng
If cell.Value = "123" Then
cell.EntireRow.Interior.ColorIndex = 4
count = count + 1
End If
if count >= 2 Then exit For
Next
End Sub
Filtering lets you avoid looping through cells
Assuming row 1 has header, you can try:
Dim cell As Range
Dim counter As Integer
With Sheets("XYZ")
With .Range("L1", .Cells(.Rows.Count, "L").End(xlUp)) '<--| reference its column "L" cells from row 1 (header) down to last not empty row
.AutoFilter field:=1, Criteria1:="123" '<--| filter referenced range on its first (and only) column with "123"
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any cell gets filtered
For Each cell In .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<--| loop through filtered cells, skipping header
cell.EntireRow.Interior.ColorIndex = 4
counter = counter + 1 '<--| update counter
If counter = 2 Then Exit For '<--| exit at 2nd iteration
Next cell
End If
End With
.AutoFilterMode = False
End With
Here's your code with some addition:
Sub Macro3()
Sheets("XYZ").Select
Dim rng As Range
greenrows = 0
Sheets("XYZ").Select
Set rng = Range("b2:b10000")
For Each cell In rng
If cell.Value = "123" Then
If greenrows = 2 Then Exit Sub
cell.EntireRow.Interior.ColorIndex = 4
greenrows = greenrows + 1
End If
Next
End Sub
I'm writing a macro in Excel 2010 for a problem that is as follows:
I have two columns, one with a Key string value and one with a uuid. The idea is that every key should have only one uuid but as the table is now, key cell could be merged cells or single cells.
The macro needs to recognize which cells are merged and which are not, so, I have two options:
If cell is merged, check all its adjacent cells, pick first uuid value and copy/paste it to other adjacent cells, that is to say, cell below(Could be with an Offset())
If cell is not merged , but key value is repeated in multiple cells, copy/paste uuid value to adjacent cells.
So basically is to check merged cells MergeArea but I don't know if I need to iterate through its addresses or check cells in the range with an offset of Offset(0,1) or what.
With my code I can know if the cells are merged but now, how con I iterate through it's adjacent cells values?
Code as is now:
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.count).End(xlUp).row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
rng.Select
For Each cell In rng
If cell.MergeCells Then
'Code for merged cells
Else
'Code to use for single cells
End If
Next cell
End With
ExitProgram:
Exit Sub
End Sub
Option Explicit
Sub CopyUUID()
Const UUID As Long = 31 'col AE
Dim lRow As Long, cel As Range, isM As Boolean, copyID As Boolean, kCol As Long
With ActiveSheet
kCol = -25 'col F
lRow = .Cells(.Rows.Count, UUID + kCol).End(xlUp).Row
For Each cel In .Range(.Cells(3, UUID), .Cells(lRow, UUID))
isM = cel.Offset(0, kCol).MergeCells
copyID = isM And Len(cel.Offset(0, kCol)) = 0
copyID = copyID Or (Not isM And cel.Offset(0, kCol) = cel.Offset(-1, kCol))
If copyID Then cel = cel.Offset(-1)
Next
End With
End Sub
Try the following code. Note that this is going to overwrite the current contents of UUID, so make a backup copy before testing. If you don't want the UUID column modified, you can modify this to suit your needs.
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim c As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
' Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.Count).End(xlUp).Row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
' rng.Select
For Each c In rng
If c.MergeCells Then
'Code for merged cells
c.Offset(0, 1).Formula = c.MergeArea.Cells(1, 1).Offset(0, 1).Formula
Else
'Code to use for single cells
If c.Formula = c.Offset(-1, 0).Formula Then
c.Offset(0, 1).Formula = c.Offset(-1, 1).Formula
End If
End If
Next c
End With
ExitProgram:
Exit Sub
End Sub
When in a MergedCell, it makes the UUID the same as the UUID of the first cell in the merged area. When not in a MergedCell, it copies UUID from the row above if Key is the same as the row above.
I changed your variable cell to c (I don't like to use variable names that can be confused with built-ins) and commented out a couple of lines.
Hope this helps
I adopt a simple approach to this problem as illustrated through steps taken by me.
sample sheet showing data with merged cells and unmerged cells.
Run the program code to unmerge the cells. Output of the program is appended below.
If this structure of data matches your case then addition of 2 lines of code for column B will leave the data as per following image.
Program code is as follows:
'Without column deletion:
Sub UnMergeRanges()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
End Sub
'With coumn deletion
Sub UnMergeRangesB()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
End Sub
I need to find the first blank row in a workbook and write information to (row, 1) and (row, 2). I think I'm currently pretty stuck...
Function WriteToMaster(num, path) As Boolean
'Declare variables
Dim xlApp As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Dim infoLoc As Integer
Set xlApp = New Excel.Application
Set wb = xlApp.Workbooks.Open("PATH OF THE DOC")
Set ws = wb.Worksheets("Sheet1")
'Loop through cells, looking for an empty one, and set that to the Num
Cells(1, 1).Select
For Each Cell In ws.UsedRange.Cells
If Cell.Value = "" Then Cell = Num
MsgBox "Checking cell " & Cell & " for value."
Next
'Save, close, and quit
wb.Save
wb.Close
xlApp.Quit
'Resets the variables
Set ws = Nothing
Set wb = Nothing
Set xlApp = Nothing
Thanks so much for any help.
If you mean the row number after the last row that is used, you can find it with this:
Dim unusedRow As Long
unusedRow = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
If you mean a row that happens to be blank with data after it... it gets more complicated.
Here's a function I wrote which will give you the actual row number of the first row that is blank for the provided worksheet.
Function firstBlankRow(ws As Worksheet) As Long
'returns the row # of the row after the last used row
'Or the first row with no data in it
Dim rw As Range
For Each rw In ws.UsedRange.Rows
If rw.Address = ws.Range(rw.Address).SpecialCells(xlCellTypeBlanks). _
Address Then
firstBlankRow = rw.Row
Exit For
End If
Next
If firstBlankRow = 0 Then
firstBlankRow = ws.Cells.SpecialCells(xlCellTypeLastCell). _
Offset(1, 0).Row
End If
End Function
Usage example: firstblankRow(thisworkbook.Sheets(1)) or pass any worksheet.
Edit: As ooo pointed out, this will error if there are no blank cells in your used range.
I would have done it like this. Short and sweet :)
Sub test()
Dim rngToSearch As Range
Dim FirstBlankCell As Range
Dim firstEmptyRow As Long
Set rngToSearch = Sheet1.Range("A:A")
'Check first cell isn't empty
If IsEmpty(rngToSearch.Cells(1, 1)) Then
firstEmptyRow = rngToSearch.Cells(1, 1).Row
Else
Set FirstBlankCell = rngToSearch.FindNext(After:=rngToSearch.Cells(1, 1))
If Not FirstBlankCell Is Nothing Then
firstEmptyRow = FirstBlankCell.Row
Else
'no empty cell in range searched
End If
End If
End Sub
Updated to check if first row is empty.
Edit: Update to include check if entire row is empty
Option Explicit
Sub test()
Dim rngToSearch As Range
Dim firstblankrownumber As Long
Set rngToSearch = Sheet1.Range("A1:C200")
firstblankrownumber = FirstBlankRow(rngToSearch)
Debug.Print firstblankrownumber
End Sub
Function FirstBlankRow(ByVal rngToSearch As Range, Optional activeCell As Range) As Long
Dim FirstBlankCell As Range
If activeCell Is Nothing Then Set activeCell = rngToSearch.Cells(1, 1)
'Check first cell isn't empty
If WorksheetFunction.CountA(rngToSearch.Cells(1, 1).EntireRow) = 0 Then
FirstBlankRow = rngToSearch.Cells(1, 1).Row
Else
Set FirstBlankCell = rngToSearch.FindNext(After:=activeCell)
If Not FirstBlankCell Is Nothing Then
If WorksheetFunction.CountA(FirstBlankCell.EntireRow) = 0 Then
FirstBlankRow = FirstBlankCell.Row
Else
Set activeCell = FirstBlankCell
FirstBlankRow = FirstBlankRow(rngToSearch, activeCell)
End If
Else
'no empty cell in range searched
End If
End If
End Function
Update
Inspired by Daniel's code above and the fact that this is WAY! more interesting to me now then the actual work I have to do, i created a hopefully full-proof function to find the first blank row in a sheet. Improvements welcome! Otherwise, this is going to my library :)
Hopefully others benefit as well.
Function firstBlankRow(ws As Worksheet) As Long
'returns the row # of the row after the last used row
'Or the first row with no data in it
Dim rngSearch As Range, cel As Range
With ws
Set rngSearch = .UsedRange.Columns(1).Find("") '-> does blank exist in the first column of usedRange
If Not rngSearch Is Nothing Then
Set rngSearch = .UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks)
For Each cel In rngSearch
If Application.WorksheetFunction.CountA(cel.EntireRow) = 0 Then
firstBlankRow = cel.Row
Exit For
End If
Next
Else '-> no blanks in first column of used range
If Application.WorksheetFunction.CountA(Cells(.Rows.Count, 1).EntireRow) = 0 Then '-> is the last row of the sheet blank?
'-> yeap!, then no blank rows!
MsgBox "Whoa! All rows in sheet are used. No blank rows exist!"
Else
'-> okay, blank row exists
firstBlankRow = .UsedRange.SpecialCells(xlCellTypeBlanks).Row + 1
End If
End If
End With
End Function
Original Answer
To find the first blank in a sheet, replace this part of your code:
Cells(1, 1).Select
For Each Cell In ws.UsedRange.Cells
If Cell.Value = "" Then Cell = Num
MsgBox "Checking cell " & Cell & " for value."
Next
With this code:
With ws
Dim rngBlanks As Range, cel As Range
Set rngBlanks = Intersect(.UsedRange, .Columns(1)).Find("")
If Not rngBlanks Is Nothing Then '-> make sure blank cell exists in first column of usedrange
'-> find all blank rows in column A within the used range
Set rngBlanks = Intersect(.UsedRange, .Columns(1)).SpecialCells(xlCellTypeBlanks)
For Each cel In rngBlanks '-> loop through blanks in column A
'-> do a countA on the entire row, if it's 0, there is nothing in the row
If Application.WorksheetFunction.CountA(cel.EntireRow) = 0 Then
num = cel.Row
Exit For
End If
Next
Else
num = usedRange.SpecialCells(xlCellTypeLastCell).Offset(1).Row
End If
End With
I know this is an older thread however I needed to write a function that returned the first blank row WITHIN a range. All of the code I found online actually searches the entire row (even the cells outside of the range) for a blank row. Data in ranges outside the search range was triggering a used row. This seemed to me to be a simple solution:
Function FirstBlankRow(ByVal rngToSearch As Range) As Long
Dim R As Range
Dim C As Range
Dim RowIsBlank As Boolean
For Each R In rngToSearch.Rows
RowIsBlank = True
For Each C In R.Cells
If IsEmpty(C.Value) = False Then RowIsBlank = False
Next C
If RowIsBlank Then
FirstBlankRow = R.Row
Exit For
End If
Next R
End Function
ActiveSheet.Range("A10000").End(xlup).offset(1,0).Select
very old thread but .. i was lookin for an "easier"... a smaller code
i honestly dont understand any of the answers above :D
- i´m a noob
but this should do the job. (for smaller sheets)
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Add
reads every cell in col 1 from bottom up and stops at first empty cell
intRow = 1
Do until objExcel.Cells(intRow, 1).Value = ""
intRow = intRow + 1
Loop
then you can write your info like this
objExcel.Cells(intRow, 1).Value = "first emtpy row, col 1"
objExcel.Cells(intRow, 2).Value = "first emtpy row, col 2"
etc...
and then i recognize its an vba thread ... lol
Very old thread but a simpler take :)
Sub firstBlank(c) 'as letter
MsgBox (c & Split(Range(c & ":" & c).Find("", LookIn:=xlValues).address, "$")(2))
End Sub
Sub firstBlank(c) 'as number
cLet = Split(Cells(1, c).address, "$")(1)
MsgBox (cLet & Split(Range(cLet & ":" & cLet).Find("", LookIn:=xlValues).address, "$")(2))
End Sub
Function firstBlankRow() As Long
Dim emptyCells As Boolean
For Each rowinC In Sheet7.Range("A" & currentEmptyRow & ":A5000") ' (row,col)
If rowinC.Value = "" Then
currentEmptyRow = rowinC.row
'firstBlankRow = rowinC.row 'define class variable to simplify computing complexity for other functions i.e. no need to call function again
Exit Function
End If
Next
End Function