Looping through all worksheets VBA - vba

I am trying to loop through all the worksheets in the activeworkbook to perform a repetitive task.
I currently have the code below:
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim rng1 As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
'This is marking several of the sheets of which I do not want to run the sub
If ws.Range("a9").Value = "x" Then
NextIteration:
End If
'Reference point is rng1 to select the desired range
With Range("a1:t100")
rng1 = .Find(what:="sector", LookIn:=xlValues).Row
End With
'return the row number for the sector header
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
'I am going to add the code below to finish out the task that I want to complete
Next
End Sub
I am sure the problem is that I'm misunderstanding something about how the for each loop actually works. Hopefully someone's answer will allow to better understand.
I really appreciate any help on this.
I made some edits to the code, and now I actually do have an error :) I tried making the changes you suggested for the "with ws.range etc..." piece of the code, and I get the object error 91.
Below is my new and "improved" code.
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim intAnchorRow As Integer
Dim intMktCapAnchor As Integer
Dim intSectorAnchor As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In ActiveWorkbook.Worksheets
'Filter out the sheets that we don't want to run
If ws.Range("a9").Value <> "x" Or ws.Name = "__FDSCACHE__" Or ws.Name = "INDEX" Then
'Get the anchor points for getting sort range and the sort keys
''''''THIS IS THE PART THAT IS NOW GIVING ME THE ERROR'''''''
With ws.Range("a1:t100")
intAnchorRow = .Find(what:="sector", LookIn:=xlValues).Row
intSectorAnchor = .Find(what:="sector", LookIn:=xlValues).Column
intMktCapAnchor = .Find(what:="Market Cap", LookIn:=xlValues).Column
End With
'Find the last row and column of the data range
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
Set SortRng = Range(Cells(intAnchorRow + 1, 1), Cells(LastRow, LastCol))
Range(SortRng).Sort key1:=Range(Cells(intAnchorRow + 1, intSectorAnchor), Cells(LastRow, intSectorAnchor)), _
order1:=xlAscending, key2:=Range(Cells(intAnchorRow + 1, intMktCapAnchor), Cells(LastRow, intMktCapAnchor)), _
order2:=xlDescending, Header:=xlNo
End If
Next
End Sub
Thanks again. This has been very helpful for me.

If I've understood your issue correctly, you don't want to use a worksheet with an x in cell A9.
If that's the case I would change the condition of the if statement to check if the cell does not contain the x. If this is true, it enters the rest of the code. If not, it goes to the next iteration.
Also, your NextIteration: doesn't do anything in the If statement.
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim rng1 As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
'This is marking several of the sheets of which I do not want to run the sub
If ws.Range("a9").Value <> "x" Then
'Reference point is rng1 to select the desired range
With Range("a1:t100")
rng1 = .Find(what:="sector", LookIn:=xlValues).Row
End With
'return the row number for the sector header
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
'I am going to add the code below to finish out the task that I want to complete
End If
Next
End Sub
The : operator is used to return the code to that line after a goto call.
For example
sub gotoEx()
for i = 1 to 10
if i = 5 then
goto jumpToHere
end if
next i
jumpToHere: '<~~ the code will come here when i = 5
'do some more code
end sub
And of course you can use this structure in your code if you wish, and have the jumpToHere: line just before the next
e.g.
for each ws in wb.Worksheets
if ws.Range("a9").Value = "x" then
goto jumpToHere
end if
'the rest of your code goes here
jumpToHere:
next

Related

VBA - Find lastColumn and Check if First Row Is Empty

I am not too sure how I should solve this issue, but there are two methods that make sense to me..
Some of the sheets in my workbook do not have headers, so I use the below code to insert a blank row and assign a header to column A - I know column A will always be employee number.
Sub insertRow()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim wkbk1 As Workbook
Set wkbk1 = Workbooks("testWorkbook.xlsm")
'Set sheets to be used in each workbook
Set ws1 = wkbk1.Sheets("mySheet")
Set ws2 = wkbk1.Sheets("hisSheet")
Set ws3 = wkbk1.Sheets("herSheet")
wkbk1.Activate
ws1.Range("A1").EntireRow.Insert
ws1.Range("A1").Value = "Employee Number"
ws2.Range("A1").EntireRow.Insert
ws2.Range("A1").Value = "Employee Number"
ws3.Range("A1").EntireRow.Insert
ws3.Range("A1").Value = "Employee Number"
End Sub
The below code deletes columns based on the header name.
Sub ManipulateSheets()
Dim a As Long, w As Long
Dim keepCols As Variant
Dim wkbk1 As Workbook
Set wkbk1 = Workbooks("testWorkbook.xlsm")
keepCols = Array("Employee Number", "Status")
wkbk1.Activate
With wkbk1
For w = 1 To .Worksheets.count
With Worksheets(w)
For a = .Columns.count To 1 Step -1
If UBound(Filter(keepCols, .Cells(1, a), True, vbTextCompare)) < 0 Then _
.Columns(a).EntireColumn.Delete
Next a
End With
Next w
End With
End Sub
The issue is this:
The 3 sheets that I insert a row in and set the column header for column A to Employee Number, still has empty headers for the remainder of the row.. So when I run the code above to delete the columns, nothing happens on these 3 sheets as there is no data to compare to in the header.
So the two options I thought would work are:
Find the lastColumn and insert text into the cells between column A and the lastColumn
Find the lastColumn and include a criteria in the if statement that looks for blank cells as well as non-matching headers
I got the code to find the lastColumn here:
Excel VBA- Finding the last column with data
Sub findColumn()
Dim rLastCell As Range
Dim i As Long
Dim MyVar As Variant
Dim ws1 As Worksheet
Dim wkbk1 As Workbook
i = 2
Set wkbk1 = Workbooks("testWorkbook.xlsm")
Set ws2 = wkbk1.Sheets("ws1")
Set rLastCell = ws2.Cells.Find(What:="*", After:=ws2.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
End Sub
I'm thinking of a Do While Loop along the lines of the below:
Do While (MyVar1 >= 2 And MyVar1 < rLastCell.Column)
Loop
You could change the condition to
IsError(Application.Match(rng.Value, keepCols, 0))
That picks up all non-matching items.
Note:
For Each rng In Intersect(.Rows(1), .UsedRange)
The above is going to loop through the used range of row 1 in the selected sheet.
Looping multiple sheets might be something like:
Option Explicit
Sub test()
Dim keepCols()
keepCols = Array("Employee Number", "Status")
Dim unionRng As Range, rng As Range, ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
With ws
If Application.WorksheetFunction.CountA(.Rows(1)) > 0 Then
For Each rng In Intersect(.Rows(1), .UsedRange)
If IsError(Application.Match(rng.Value, keepCols, 0)) Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, rng)
Else
Set unionRng = rng
End If
End If
Next rng
If Not unionRng Is Nothing Then
Debug.Print unionRng.EntireColumn.Address 'unionRng.EntireColumn.Delete '. ''<== Swop when ready to delete
Set unionRng = Nothing
End If
End If
End With
Next ws
End Sub

VBA Vlookup value same as first row

I'm trying to use vlookup() function under for loop condition, but the value only follow only the first row value. This is my code. Sorry, the code is quite messy; I'm still learning VBA.
Sub vlookup_Click()
Application.ScreenUpdating = False
Dim result As String
Dim i As Long
Dim iLast As Long
Dim result1 As String
Dim sheet As Worksheet
Dim sheet1 As Worksheet
Dim WrkSht As String
WrkSht = "Sheet1"
iLast = ActiveWorkbook.Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set sheet = ActiveWorkbook.Sheets("Sheet1")
Set sheet1 = ActiveWorkbook.Sheets("InventoryReport")
For i = 10 To iLast
result = Application.WorksheetFunction.VLookup(sheet.Range("$B$10"), _
sheet1.Range("$B$10:$Q$48"), 16, False)
Sheets(WrkSht).Cells(i, 9).Value = result
Next i
End Sub
Below picture shows the result.Any idea to solve this?
Expected and Current Result:
So let's consider dumping the VLOOKUP() option. We are using VBA, so we have more power when it comes to looking up ranges.
I think we should go with using the range.Find() method here. Set this object, use the Row() property to match the Q column on that range, and return it to your I column in ws1.
Try this
Sub vlookup_Click()
Application.ScreenUpdating = False
Dim i As Long
Dim iLast As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim findRng As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("InventoryReport")
'Changed ActiveWorksheet to ws1 for your iLast
iLast = ws1.Range("A" & Rows.Count).End(xlUp).Row
For i = 10 To iLast
Set findRng = ws2.Range("B:B").Find(ws1.Cells(i, "B"), , xlValues, xlWhole)
If Not findRng Is Nothing Then
ws1.Cells(i, "I") = ws2.Cells(findRng.Row, "Q")
Else
ws1.Cells(i, "I") = 0
End If
Set findRng = Nothing
Next i
Application.ScreenUpdating = True
End Sub
I see you use the excel worksheet function, but use the form of formulaR1C1 will be better. And record the Macro will free you from calculate the row# for the formula.
how to do:
You can just video this operation to get that code in your excel by click Tab "Developer" in your
excel/"record Macro" then input the formular in the cell then "stop recording" then Alt+F11 to get to
access the code of the vlookup formula:
ActiveCell.FormulaR1C1 = "=VLOOKUP(R10C2,R[3]C[-1]:R[41]C[11],16,0)"

Checking if there is any data entered into a range of cells using VBA in Excel

I'm trying to call a Sub (New_Row) when the first empty row (minus the last column) is filled. I'm having trouble with how to reference a range of cells in the If statement toward the end.
Sub Data_Added()
'Check if anything has been entered into the first empty row in "Data"
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Sheets("Data").Select
Set sht = Worksheets("Data")
Set StartCell = Range("A1").End(xlDown).Select
Worksheets("Data").UsedRange
LastRow = StartCell.SpecialCells(xlCellTypeLastCell).Row
LastColumn = StartCell.SpecialCells(xlCellTypeLastCell).Column
Set InputRange = sht.Range(StartCell, sht.Cells(LastRow + 1, LastColumn - 1))
If InputRange Is Not Nothing Then
Call New_Row
End If
End Sub
I've seen people using the Application.Intersect method, but I'm not sure if an intersect makes sense for just one row of cells. Totally new to VBA, though, so I don't know. Right now I'm getting an "Invalid use of Object" error pointing at the "Nothing" in the If statement.
Dim y As Long, lastx As Long
Dim sht As Worksheet
y = 1 'Row you want to check
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastx = sht.Cells(y, sht.Columns.Count).End(xlToRight).Column - 1
If WorksheetFunction.CountA(Range(Cells(y, 1), Cells(y, lastx))) <> 0 Then 'Call New_Row when the row you are checking is empty
Call New_Row
End If
Have you tried something like this?

How to iterate through rows in sheet1 given cell value in sheet2 and replace row in sheet1 with row in sheet 2?

I have to find and replace rows in sheet 1 given matching cell value in the same column in sheet2. The column number is 4.
HELPPP!!!
This is what I have right now and I get an error on next x.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets(Sheet1)
Set ws2 = Sheets(sheet2)
With wb
For i = 1 To ws2.Cells(Rows.Count, 4).End(xlUp).Row
Dim lookupvalue As String
lookupvalue = ws2.Cells(i, 4).Value
For x = 1 To ws1.Cells(Rows.Count, 4).End(xlUp).Row
Dim rng As range
For Each rng In range("D:D")
If InStr(1, rng.Value, "lookupvalue") > 0 Then
rng.Delete
End If
Next x
exitloop:
Next i
End With
End Sub
As A.S.H. said, the code needs a little improvement:
1) The two inner loops need to be combined.
2) The new inner loop should go from the bottom up, due to the fact that you are deleting the cell, This is probably why you have the second inner loop but that just adds time to the sub.
3) you are currently only deleting the one cell at a time, any data around it will remain. This may be what you want and so I left it, but if you meant to delete the entire row then uncomment the line that does that.
4) when testing with the instr function the variable should not be in quotes, with the variable in quotes it will look for that specific word "lookupvalues" and not the value assigned to that variable.
5) The with block that was being used did nothing. when using the with block the line that use it need to start with a '.' for example: on your code the with was with the workbook so every time a worksheet is used it should start with a "." like .ws1... and so forth. But by declaring the sheets using the workbook, this is no longer needed.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim lookupvalue As String
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("sheet2")
For i = 1 To ws2.Cells(Rows.Count, 4).End(xlUp).Row
lookupvalue = ws2.Cells(i, 4).Value
For x = ws.Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
Set rng = ws.Cells(x, 4)
If InStr(1, rng.Value, lookupvalue) > 0 Then
rng.Delete 'this only deletes the cell
'You may want this instead
'rng.entirerow.delete
End If
Next x
Next i
End Sub
I would like to propose an alternative way to handle this using a For Each Loop and the Find Method of the Range object.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lookup_rng As Range
Dim lookupvalue As String
Dim search_rng As Range
Dim rng As Range
Dim match_rng As Range
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Set lookup_rng = Application.Intersect(ws2.Range("D:D"), ws.UsedRange)
Set search_rng = Application.Intersect(ws.Range("D:D"), ws2.UsedRange)
For Each rng In lookup_rng.Cells
lookupvalue = rng.Value
With search_rng
Set match_rng = .Find(lookupvalue, LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlPrevious)
Do Until NoMoreMatches(match_rng)
match_rng.Delete 'Or match_rng.EntireRow.Delete if you want to delete the entire row.
Set match_rng = .FindPrevious
Loop
End With
Next
End Sub
Private Function NoMoreMatches(MatchRng As Range) As Boolean
NoMoreMatches = MatchRng Is Nothing
End Function
This approach is a little bit more wasteful then that of Scott Craner since the Find method always starts from the end of the range. However, I think it has the advantage that it is easier to read, i.e. that the code more directly shows what it is supposed to do.
Moreover, using this version you could extract the loops into a separate Sub you can use for arbitrary lookup and search ranges.

VBA code to combine multiple worksheets mostly works, but is producing unexpected results

Scenario: A workbook will have a variable number of worksheets, each with a variable number of populated cells, most commonly in Column A only but not necessarily. There is no header row. I want to combine all the worksheets into a single "master" worksheet, after which I will perform various shenanigans later on. What I have "mostly" works, but for some reason it leaves Row 1 blank, which I do not want. I suppose I could just delete the empty row, but that seems awfully cheesy and doesn't solve the underlying problem, which is that I don't understand why it's doing this.
Code:
Private Sub cmdFinalize_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim final As Worksheet
Dim rng As Range
Dim colCount As Integer
Set wb = ActiveWorkbook
Set final = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
final.Name = "Final"
Set ws = wb.Worksheets(1)
colCount = ws.Cells(1, 255).End(xlToLeft).Column
For Each ws In wb.Worksheets
If ws.Index = wb.Worksheets.Count Then
Exit For
End If
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(65536, 1).End(xlUp).Resize(, colCount))
final.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next ws
End Sub
I assumed the Offset(1) was causing the problem, but removing it entirely causes the last row item of every worksheet to be overwritten by the first line of the next one when it all gets glued together on the 'Master' worksheet.
You need to use offset(1) only for second and after worksheet.
Following code use a flag to indicate the processing worksheet is first or not.
Private Sub cmdFinalize_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim final As Worksheet
Dim rng As Range
Dim colCount As Integer
Dim firstWorksheetFlag as boolean 'Flag to indicate the first worksheet is in process
firstWorksheetFlag = True ' Flag is true at begin
Set wb = ActiveWorkbook
Set final = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
final.Name = "Final"
Set ws = wb.Worksheets(1)
colCount = ws.Cells(1, 255).End(xlToLeft).Column
For Each ws In wb.Worksheets
If ws.Index = wb.Worksheets.Count Then
Exit For
End If
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(65536, 1).End(xlUp).Resize(, colCount))
If firstWorksheetFlag 'Offset(1) is not used.
final.Cells(65536, 1).End(xlUp).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
firstWorksheetFlag = False ' first worksheet has been processed, so next is not first.
Else 'second or later worksheet, so Offset(1) is used.
final.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count,rng.Columns.Count).Value = rng.Value
End If
Next ws
End Sub