Implement search box into current worksheet with macro - excel

My macro currently works by pressing CTRL+F to open the search box which searches either REF1 or REF2. If the information is found, it copies over to the next cell basically to show it's there. If the information is not found, it pastes the data searched for in cell L4 so a label can be printed.
What I'm trying to do:
Remove the CTRL+F and basically run from a cell (let's say cell L18). However, when scanned the scanner basically types in the numbers then presses enter/return.
I was wondering, would it be possible to make it run like this.
Select cell L18 then keep scanning until either:
A) The list is done - nothing is missing
B) If REF1/REF2 doesn't match, pastes that data into cell L4 for a label to be printing.
(Current version using CTRL+F): http://oi39.tinypic.com/mima9x.jpg
(Example of what I need): http://oi42.tinypic.com/24fiwt1.jpg
Current macro:
Sub Extra_Missing_Item() Application.ScreenUpdating = False
Dim rangeToSearch As Range
With Sheets(1)
Set rangeToSearch = .Range("A2:B" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Dim searchAmount As String
searchAmount = InputBox("Scan the REF1 or REF2:")
Dim cell As Range
Set cell = rangeToSearch.Find(searchAmount, LookIn:=xlValues)
With Sheets(1)
If Not cell Is Nothing Then
.Range("E" & cell.Row & ":G" & cell.Row).Value = _
.Range("A" & cell.Row & ":C" & cell.Row).Value
Else
MsgBox "REF1/REF2: " & searchAmount & " shouldn't be here"
.Range("L4").Value = searchAmount
Range("L9").Select
End If
End With
Application.ScreenUpdating = True
End Sub

I think I understand what you need. This macro calls each time any cell on the sheet changed (but if changed cell is not L18, macro do nothing):
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Range("L18")) Is Nothing Then
Exit Sub
End If
Dim rangeToSearch As Range
Dim searchAmount As String
Dim cell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Set rangeToSearch = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row)
searchAmount = Target.value
Set cell = rangeToSearch.Find(searchAmount, LookIn:=xlValues)
If Not cell Is Nothing Then
Range("E" & cell.Row & ":G" & cell.Row).value = _
Range("A" & cell.Row & ":C" & cell.Row).value
Else
MsgBox "REF1/REF2: " & searchAmount & " shouldn't be here"
Range("L4").value = searchAmount
End If
Range("L18").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Put this macro in the Sheet module (coresponding to the sheet where your data is):

Related

How to go to previous cell and make this code faster?

When running code that deletes an EntireRow, going to next cell will not delete the next cell based on the same parameters because that cell gets moved down into the current slot.
IE:
for each cell in r
if cell.value = "A" then cell.entirerow.delete
next cell
The above code will delete A1 if A1="A" but if A2 also = "A" it will not be deleted because when it goes to next cell A2 it was moved to A1. When it's now looking at A2, that is the cell that was A3, so at best it looks at every other cell.
To get around this i do stuff like this:
DoItAgain:
For Each cell In r
If cell.Value = "A" Then
cell.EntireRow.Delete
GoTo DoItAgain
End If
next cell
This works well but when running this code on 100k lines, it takes way too long. I'm thinking that's because my DoItAgain method brings it all the way back to the first cell and that's a lot of cells to loop through if there's 100k or more cells to look at.
This is the entire code I'm using right now. It was working very well until I started receiving a lot more data and then it's taking too long for it to be useful:
Private Sub Ford_Inventory_Variance_File_CleanUp()
Call ScreenOff
If IsEmpty(Range("A2")) Then Range("A2").EntireRow.Delete
If IsEmpty(Range("A1")) Then Range("A1").EntireRow.Delete
LastRow = ActiveWorkbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
DoItAgain2:
Set r = ActiveWorkbook.ActiveSheet.Range("A20:A" & LastRow)
For Each cell In r
If cell.Value = "**** End Of Report ****" Then GoTo ItsTrimmed
cell.Value = Trim(cell.Value)
If IsEmpty(cell.Value) Then
cell.EntireRow.Delete
GoTo DoItAgain2
End If
Next cell
ItsTrimmed:
DoItAgain:
For Each cell In r
If cell.Value = "**** End Of Report ****" Then Exit Sub
If InStr(1, (cell.Value), "/") = 0 And InStr(1, (cell.Value), "Total of Inventory") = 0 Then
cell.EntireRow.Delete
GoTo DoItAgain
End If
If Not IsNumeric(Left(cell.Value, 1)) And InStr(1, (cell.Value), "Total of Inventory") = 0 Then
cell.EntireRow.Delete
GoTo DoItAgain
End If
Next cell
Call ScreenOn
End Sub
Screenupdating is off, but this code takes forever. instead of Next cell can I use Previous cell? Is previous cell a thing? Maybe I could use previous cell instead of GoTo DoItAgain?
Any input on how to speed this up will be greatly appreciated. I write codes like this a lot using my GoTo DoItAgain method, i probably have 100 macro's like this, but I might need a better way. My boss is entrusting me with more work but I need to speed this process up.
Thank you in advance.
Try the next code, please. It is untested, but it should work. It, basically, works on the next mechanism: It iterates between all cells of the defined range and check each of them against the set conditions. If a condition is True, it marks the cell like necessary to be deleted (making the boolean variable True). After that, in case of boolToDelete = True, the respective cell it is added to the rngDel (range to be deleted). Finally, usingrngDel, all the rows are deleted at once (very fast):
Private Sub Ford_Inventory_Variance_File_CleanUp()
Dim sh As Worksheet, lastRow As Long, i As Long, rngDel As Range, boolToDelete As Boolean
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
For i = 20 To lastRow
If sh.Range("A" & i).Value = "" Then
boolToDelete = True
ElseIf InStr(sh.Range("A" & i).Value, "/") = 0 And InStr(sh.Range("A" & i).Value, "Total of Inventory") = 0 Then
boolToDelete = True
ElseIf Not IsNumeric(left(sh.Range("A" & i).Value, 1)) And InStr(sh.Range("A" & i).Value, "Total of Inventory") = 0 Then
boolToDelete = True
End If
If boolToDelete Then
If rngDel Is Nothing Then 'for first time (when rngDel is nothing)
Set rngDel = sh.Range("A" & i)
Else 'next times a union of existing rngDel and the processed cell is created
Set rngDel = Union(rngDel, sh.Range("A" & i))
End If
End If
boolToDelete = False 'reinitialize the boolean variable
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp 'rng deletion at once
End Sub
FaneDuru gets 100% credit for answering my question.
I'm posting the full modified code I'm using however:
Private Sub Ford_Inventory_Variance_File_CleanUp()
Dim sh As Worksheet, lastRow As Long, i As Long, rngDel As Range, boolToDelete As Boolean
If IsEmpty(Range("A2")) Then Range("A2").EntireRow.Delete
If IsEmpty(Range("A1")) Then Range("A1").EntireRow.Delete
lastRow = ActiveWorkbook.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set r = ActiveWorkbook.ActiveSheet.Range("A1:N" & lastRow)
For Each cell In r
cell.Value = Trim(cell.Value)
Next cell
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
For i = 20 To lastRow
If sh.Range("A" & i).Value = "" Then
boolToDelete = True
ElseIf InStr(sh.Range("A" & i).Value, "/") = 0 And InStr(sh.Range("A" & i).Value, "Total of Inventory") = 0 And sh.Range("A" & i).Value <> "**** End Of Report ****" Then
boolToDelete = True
ElseIf Not IsNumeric(Left(sh.Range("A" & i).Value, 1)) And InStr(sh.Range("A" & i).Value, "Total of Inventory") = 0 And sh.Range("A" & i).Value <> "**** End Of Report ****" Then
boolToDelete = True
End If
If boolToDelete Then
If rngDel Is Nothing Then
Set rngDel = sh.Range("A" & i)
Else
Set rngDel = Union(rngDel, sh.Range("A" & i))
End If
End If
boolToDelete = False
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub
Everything Dane wrote is fast. The longest part of my code is now the trim function I wrote where it trims all the cells in ("A1:N" & LastRow).

Excel VBA: Optimizing Worksheet_Change function to avoid "Not enough system resource to display completely"

First I need to say that I a beginner with VBA. I understand VBA basics and I already did some little projects but most of it involved a lot of googling.
For the current issue, I could not find any useful tips online. Maybe it's because I created the code on my own. But see for yourself...
I am trying to create a table with client data. The table contains the client number in column "I" which is being added by hand. The table should now pick up other client data such as domicile, age, etc automatically based on the client number from a static database that is in another tab. However, I want to have the possibility to manually overwrite the cells in my table that contain the client data from the database. But when I delete my manual entries the original data from the database should appear again.
With the code below I was able to do this. When a cell is empty the code adds a formula to the cell that picks up the data from the database. However, I am able to overwrite the formula manually. When I delete my manual entry and the cell becomes empty again the formula appears again and picks up the data from the database. But I have two problems with the code below:
The code seems to be too "heavy". For example, when I delete rows, I get an error message "Not enough system resource to display completely" which freezes the complete Excel file.
When I add new client numbers in column "I" the code does not pick up the data from the database automatically. I need to trigger the Worksheet_Change for every single cell by choosing the cell and clicking Delete
So I am looking for a way to simplify my code so that:
the error message does not occur again when I am deleting rows;
when I add a new client number in column "I" the other cells in the same row should instantly pickup other client data from the database.
I already tried the following but without success:
To delete rows I created a code that does it automatically and I added Application.EnableEvents = False at the beginning of the code and Application.EnableEvents = True at the end with the intention to stop the Worksheet_Change while the rows are being deleted but it did not work and I still got an error.
To trigger the Worksheet_Change I used the following code Application.Run "Sheet3.Worksheet_Change", Range("A1:Z5000") and assigned it to a button but it did not work.
So here is the existing code (note the code look longer than it is. The code for every column is the same, only the formulas is different that is being put into the cells are different):
Private Sub Worksheet_Change(ByVal Target As Range)
'Code for column B
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Me.Range("B2:B" & Me.Rows.Count))
If Not AffectedRange Is Nothing Then
Dim iCell As Range
For Each iCell In AffectedRange.Cells
If iCell.Value = vbNullString Then
iCell.Formula = "=IFERROR(IF($I" & iCell.Row & "="""","""",VLOOKUP($I" & iCell.Row & ",'Raw Data'!$A$1:$AH$5000,4,FALSE)),""N/A"")"
End If
Next iCell
End If
'Code for column D
Dim AffectedRange1 As Range
Set AffectedRange1 = Intersect(Target, Me.Range("D2:D" & Me.Rows.Count))
If Not AffectedRange1 Is Nothing Then
Dim iCell1 As Range
For Each iCell1 In AffectedRange1.Cells
If iCell1.Value = vbNullString Then
iCell1.Formula = "=IFERROR(IF($I" & iCell1.Row & "="""","""",IF(VLOOKUP($I" & iCell1.Row & ",'Raw Data'!$A$1:$AH$5000,9,FALSE)=0,""N/A"",VLOOKUP($I" & iCell1.Row & ", 'Raw Data'!$A$1:$AH$5000,9,FALSE))),""N/A"")"
End If
Next iCell1
End If
'Code for column E
Dim AffectedRange2 As Range
Set AffectedRange2 = Intersect(Target, Me.Range("E2:E" & Me.Rows.Count))
If Not AffectedRange2 Is Nothing Then
Dim iCell2 As Range
For Each iCell2 In AffectedRange2.Cells
If iCell2.Value = vbNullString Then
iCell2.Formula = "=IFERROR(IF($I" & iCell2.Row & "="""","""",IF(VLOOKUP($I" & iCell2.Row & ",'Raw Data'!$A$1:$AH$5000,10,FALSE)=0,""N/A"",VLOOKUP($I" & iCell2.Row & ", 'Raw Data'!$A$1:$AH$5000,10,FALSE))),""N/A"")"
End If
Next iCell2
End If
'Code for column C
Dim AffectedRange4 As Range
Set AffectedRange4 = Intersect(Target, Me.Range("C2:C" & Me.Rows.Count))
If Not AffectedRange4 Is Nothing Then
Dim iCell4 As Range
For Each iCell4 In AffectedRange4.Cells
If iCell4.Value = vbNullString Then
iCell4.Formula = "=IFERROR(IF($I" & iCell4.Row & "="""","""",IF(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)=0,""N/A"",IF(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)<0.49999,""Prio 3"",IF(AND(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)>0.49999,VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)<0.79999),""Prio 2"",IF(VLOOKUP($I" & iCell4.Row & ",'Raw Data'!A$1:$AH$5000,22,FALSE)>0.79999,""Prio 1"",""N/A""))))),""N/A"")"
End If
Next iCell4
End If
'Code for column H
Dim AffectedRange5 As Range
Set AffectedRange5 = Intersect(Target, Me.Range("H2:H" & Me.Rows.Count))
If Not AffectedRange5 Is Nothing Then
Dim iCell5 As Range
For Each iCell5 In AffectedRange5.Cells
If iCell5.Value = vbNullString Then
iCell5.Formula = "=IFERROR(IF($I" & iCell5.Row & "="""","""",IF(VLOOKUP($I" & iCell5.Row & ",'Raw Data'!$A$1:$AH$5000,11,FALSE)=0,""N/A"",VLOOKUP($I" & iCell5.Row & ", 'Raw Data'!$A$1:$AH$5000,11,FALSE))),""N/A"")"
End If
Next iCell5
End If
'Code for column F
Dim AffectedRange6 As Range
Set AffectedRange6 = Intersect(Target, Me.Range("F2:F" & Me.Rows.Count))
If Not AffectedRange6 Is Nothing Then
Dim iCell6 As Range
For Each iCell6 In AffectedRange6.Cells
If iCell6.Value = vbNullString Then
iCell6.Formula = "=IFERROR(IF($I" & iCell6.Row & "="""","""",(IF(OR($D" & iCell6.Row & "=""N/A"",$D" & iCell6.Row & "=""""),""N/A"",IF(AND($H" & iCell6.Row & "=""Espagne"",LEN($D" & iCell6.Row & ")=5),VLOOKUP(LEFT($D" & iCell6.Row & ",2),Regionslist!$A$1:$B$52,2,FALSE),IF(AND($H" & iCell6.Row & "=""Espagne"",LEN($D" & iCell6.Row & ")=4),VLOOKUP(""0""&LEFT($D" & iCell6.Row & ",1),Regionslist!$A$1:$B$52,2,FALSE),$H" & iCell6.Row & "))))),$H" & iCell6.Row & ")"
End If
Next iCell6
End If
'Code for column G
Dim AffectedRange7 As Range
Set AffectedRange7 = Intersect(Target, Me.Range("G2:G" & Me.Rows.Count))
If Not AffectedRange7 Is Nothing Then
Dim iCell7 As Range
For Each iCell7 In AffectedRange7.Cells
If iCell7.Value = vbNullString Then
iCell7.Formula = "=IFERROR(IF($I" & iCell7.Row & "="""","""",VLOOKUP($F" & iCell7.Row & ",Regionslist!$B$1:$C$52,2,FALSE)),$F" & iCell7.Row & ")"
End If
Next iCell7
End If
'Code for column J
Dim AffectedRange8 As Range
Set AffectedRange8 = Intersect(Target, Me.Range("J2:J" & Me.Rows.Count))
If Not AffectedRange8 Is Nothing Then
Dim iCell8 As Range
For Each iCell8 In AffectedRange8.Cells
If iCell8.Value = vbNullString Then
iCell8.Formula = "=IFERROR(IF($I" & iCell8.Row & "="""","""",VLOOKUP($I" & iCell8.Row & ",'Raw Data'!$A$1:$AH$5000,2,FALSE)),""N/A"")"
End If
Next iCell8
End If
'Code for column K
Dim AffectedRange9 As Range
Set AffectedRange9 = Intersect(Target, Me.Range("K2:K" & Me.Rows.Count))
If Not AffectedRange9 Is Nothing Then
Dim iCell9 As Range
For Each iCell9 In AffectedRange9.Cells
If iCell9.Value = vbNullString Then
iCell9.Formula = "=IFERROR(IF($I" & iCell9.Row & "="""","""",IF(SUBSTITUTE(VLOOKUP($I" & iCell9.Row & ",'Raw Data'!$A$1:$AH$5000,13,FALSE),"","","""")<>"""",SUBSTITUTE(VLOOKUP($I" & iCell9.Row & ",'Raw Data'!$A$1:$AH$5000,13,FALSE),"","",""""),""N/A"")),""N/A"")"
End If
Next iCell9
End If
'Code for column L
Dim AffectedRange10 As Range
Set AffectedRange10 = Intersect(Target, Me.Range("L2:L" & Me.Rows.Count))
If Not AffectedRange10 Is Nothing Then
Dim iCell10 As Range
For Each iCell10 In AffectedRange10.Cells
If iCell10.Value = vbNullString Then
iCell10.Formula = "=IFERROR(IF($I" & iCell10.Row & "="""","""",SUBSTITUTE(VLOOKUP($I" & iCell10.Row & ",'Raw Data'!$A$1:$AH$5000,20,FALSE),"","","""")),""N/A"")"
End If
Next iCell10
End If
'Code for column M
Dim AffectedRange11 As Range
Set AffectedRange11 = Intersect(Target, Me.Range("M2:M" & Me.Rows.Count))
If Not AffectedRange11 Is Nothing Then
Dim iCell11 As Range
For Each iCell11 In AffectedRange11.Cells
If iCell11.Value = vbNullString Then
iCell11.Formula = "=IFERROR(IF($I" & iCell11.Row & "="""","""",VLOOKUP($I" & iCell11.Row & ",'Raw Data'!$A$1:$AH$5000,22,FALSE)),""N/A"")"
End If
Next iCell11
End If
'Code for column N
Dim AffectedRange12 As Range
Set AffectedRange12 = Intersect(Target, Me.Range("N2:N" & Me.Rows.Count))
If Not AffectedRange12 Is Nothing Then
Dim iCell12 As Range
For Each iCell12 In AffectedRange12.Cells
If iCell12.Value = vbNullString Then
iCell12.Formula = "=IFERROR(IF($I" & iCell12.Row & "="""","""",""1.""&VLOOKUP($I" & iCell12.Row & ",'Raw Data'!$A$1:$AH$5000,21,FALSE)),""N/A"")"
End If
Next iCell12
End If
'Code for column W
Dim AffectedRange13 As Range
Set AffectedRange13 = Intersect(Target, Me.Range("W2:W" & Me.Rows.Count))
If Not AffectedRange13 Is Nothing Then
Dim iCell13 As Range
For Each iCell13 In AffectedRange13.Cells
If iCell13.Value = vbNullString Then
iCell13.Formula = "=IF($I" & iCell13.Row & "="""","""",IFERROR(IF(VLOOKUP($I" & iCell13.Row & ",'Raw Data'!$A$1:$AH$5000,1,FALSE)=$I" & iCell13.Row & ",""yes"",""no""),""no""))"
End If
Next iCell13
End If
End sub
In advance many thanks for any kind of advice and help!
Best regards,
Oliver
You code doesn't check for changes in Col I, so you could add a block for that
'Code for column B
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Me.Range("I2:I" & Me.Rows.Count))
If Not AffectedRange Is Nothing Then
Dim iCell As Range
For Each iCell In AffectedRange.Cells
Application.EnableEvents=false
'Note the Range is *relative* to EntireRow
iCell.EntireRow.range("B1:H1,J1:M1").value = 1 'set an initial value
Application.EnableEvents=True
'Then trigger a change to set the formulas
iCell.EntireRow.range("B1:H1,J1:M1").ClearContents
Next iCell
End I

Excel macro : compare cell value with external filename/folder content

I need to complete this code, can you help me?
I have to use it inside an Excel macro.This macro have to check if what is written in each cell (inside them there are song names) is present in a specific folder in the form of files. For example if in a cell there is "Nothing Else Matter", the script will have to check if in that folder there is a file with that name. This is a script that should allow me to save time, I apologize for the errors but it is the first time I put my hand to this language (not my work, I say it for fairness).
The error that comes out is as follows:
Compilation error:
Syntax error
The problem is on the line with "If Dir(songname) "" Then"
Sub Test_if_File_exists_in_dir()
Dim RangeOfCells As Range
Dim Cell As Range
Dim songname As String
Dim TotalRow As Long
TotalRow = Range("A" & Rows.Count).End(xlUp).Row
Set RangeOfCells = Range("A2:A" & TotalRow)
For Each Cell In RangeOfCells
songname = "C:\Alessio\Songs\" & Cell & ".*"
If Dir(songname) "" Then
Cell.Font.Color = vbRed
Else
Cell.Font.Color = vbBlack
End If
Next Cell
MsgBox "Done, verify data first time"
End Sub
Thank you,
Alessio
Try this:
Sub Test_if_File_exists_in_dir()
Dim RangeOfCells As Range
Dim Cell As Range
Dim songname As String
Dim TotalRow As Long
TotalRow = Range("A" & Rows.Count).End(xlUp).Row
Set RangeOfCells = Range("A2:A" & TotalRow)
For Each Cell In RangeOfCells
'edit: include artist
songname = "C:\Alessio\Songs\" & _
Cell.Offset(0, 1) & " - " & Cell & ".*"
Debug.print "Checking: " & songname
Cell.Font.Color = IIf(Len( Dir(songname) ) = 0, vbRed, vbBlack)
Next Cell
MsgBox "Done, verify data first time"
End Sub

How do I add a Hyperlink to each item in a column?

Column B is Employee name and is also an individual Worksheet name.
Anticipated Outcome: A hyperlink to the individual Worksheet on each item in column B.
Issue: The code starts and stops at the top of the list and puts in a hyperlink to the last employee on the list.
Sub HyperlinkAdd()
ts= "Employee List"
lx = sheets(ts).Range("L1").value
Sheets(ts).Range("L1").Formula= "=Subtotal(3,B4:B1000)+3"
For x = 3 to lx
If Range("B" & x).value <> "" And Range("B" & x).value <> "Employees" Then
Sheets(ts).Hyperlinks.Add Anchor:Selection, Address:="", _
Subaddress:="'" & Range("B" & x) & "'!A1"
Else
End if
Next X
End Sub
Try this:
Sub add_hyperlink()
Dim target_range As Range
Dim cell As Range
Set target_range = ThisWorkbook.Sheets("Sheet1").Range("B1", Range("B1").End(xlDown))
For Each cell In target_range
ThisWorkbook.Sheets("Sheet1").Hyperlinks.Add Anchor:=cell, Address:="https://www.google.com/", SubAddress:= _
"Sheet1!A1", TextToDisplay:=cell.Value
Next cell
End Sub
How about the following, simply amend the range you want to work with, I've set it up so it works from B1 to the last populated cell on Column B:
Sub HyperlinkAdd()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your working worksheet, amend as required
Dim LastRow As Long
Dim rng As Range, cell As Range
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
'get the last row with data on Column b
Set rng = ws.Range(ws.Range("B1"), ws.Range("B" & LastRow))
'set the range to work with
For Each cell In rng
If cell.Value <> "" And cell.Value <> "Employees" Then
ws.Hyperlinks.Add Anchor:=cell, Address:="", SubAddress:=cell.Value & "!A1", TextToDisplay:=cell.Value
End If
Next
End Sub
I take a different tack and make a table of contents with each sheet (with exceptions) added to the list, and hyperlinks forward and back. You'll want to change the location of the "return" link on the employee sheet to somewhere suitable.
Private Sub Make_TOC()
'TOC Table of contents Hyperlink
Dim bkEmployees As Workbook
Set bkEmployees = ActiveWorkbook
Dim shContents As Worksheet, shDetail As Worksheet
If Not WorksheetExists("Contents") Then
Set shContents = bkEmployees.Sheets.Add(before:=ActiveWorkbook.Sheets(1))
shContents.Name = "Contents"
Else
Set shContents = bkEmployees.Sheets("Contents")
shContents.Move before:=bkEmployees.Sheets(1)
End If
shContents.Activate
shContents.Range("A1").Select
shContents.Columns("A:B").NumberFormat = "#"
For locX = 2 To bkEmployees.Sheets.Count
Select Case bkEmployees.Sheets(locX).Name
'add any sheets you don't want messed with
Case "Sheet1", "Sheet2", "Contents"
'don't include the sheets above in the TOC
Case Else
shContents.Cells(locX, 1) = bkEmployees.Sheets(locX).Name
shContents.Cells(locX, 1).Select
strSubAddress = "'" & shContents.Cells(locX, 1).Value & "'!A1"
shContents.Hyperlinks.Add Anchor:=shContents.Cells(locX, 1), _
Address:="", SubAddress:="'" & bkEmployees.Sheets(locX).Name & "'" & "!A1", _
TextToDisplay:=bkEmployees.Sheets(locX).Name, ScreenTip:="Go to Detail Sheet"
'change this code to put the anchor for the return link somewhere suitable.
bkEmployees.Sheets(locX).Hyperlinks.Add Anchor:=bkEmployees.Sheets(locX).Cells(1, 1), _
Address:="", SubAddress:="'" & shContents.Name & "'" & "!A" & locX, _
TextToDisplay:="Return to TOC", ScreenTip:="Return to Table of Contents"
End Select
Next locX
shContents.Range("A1").Value = "Table Of Contents"
shContents.Range("A1").Select
shContents.Columns("A").AutoFit
End Sub

Excel 2010 VBA scripting

I’m a complete newbie with VBA but have managed to cobble together the following which works fine for my worksheet where I have assigned the code to a command button. My problem is that my worksheet has in excess of 3000 rows and I don’t really want to create 3000 buttons.
My current thinking would be to have a script search a range of cells for a specific condition (i.e. TRUE) then run my original code as a subscript for each cell that matches the condition. I have tried creating a loop to match the condition being searched but don't know how to set the result(s) as an active cell.
Could anyone give me some pointer on how to achieve this or propose a better solution?
Thanks.
Sub Send_FWU_to_E_Drive()
Dim aTemp As String
Dim bTemp As String
Dim cTemp As String
Dim dTemp As String
Dim eTemp As String
Dim subdir As String
aTemp = "c:\test\"
bTemp = "E:\romdata\"
cTemp = ActiveCell.Offset(, -5) & ".fwu"
dTemp = ActiveWorkbook.path
eTemp = "\Firmware files"
subdir = "\Firmware Files\" & ActiveCell.Offset(, -5) & "\" & ActiveCell.Offset(, -5) & ".fwu"
MsgBox "The path of the active workbook is " & dTemp & subdir
If Dir(dTemp & subdir) = "" Then
MsgBox "Please check the file and ensure it is suitable for firmware updating with an SD card."
Exit Sub
End If
MsgBox "The file " & cTemp & " is being copied to " & bTemp
If Dir("e:\romdata", vbDirectory) = "" Then MkDir "E:\romdata"
If Dir(bTemp & "nul") = "" Then
MsgBox "The Destination Directory is missing, please ensure your SD Card is formatted, mapped as drive E and has a romdata directory."
Exit Sub
End If
FileCopy dTemp & subdir, bTemp & cTemp
End Sub
First modify your function to accept a range argument, which we'll call cell:
Sub Send_FWU_to_E_Drive(cell as Excel.Range)
Then change all the ActiveCell references in that Sub to cell.
The sub below loops through each cell in column B of the Active sheet and, if it's TRUE, calls your routine with the cell in column A of that row. So your offsets in the code in Send_FWU_to_E_Drive are all relative to the cell in column A. This code is untested, but should be close:
Sub Test
Dim Cell as Excel.Range
Dim LastRow as Long
With ActiveSheet
LastRow = .Range("A" & .Rows.Count).End(xlup).Row
For Each Cell in .Range("B2:B" & LastRow) 'Search for TRUE in column B
If Cell.Value = TRUE Then
Send_FWU_to_E_Drive cell.Offset(0,-1) 'Column A Cell
End If
Next Cell
End With
End Sub
EDIT: Per #Siddharth's suggestion, here's a Find/FindNext version:
Sub Test()
Dim cell As Excel.Range
Dim LastRow As Long
Dim SearchRange As Excel.Range
Dim FirstFindAddress As String
With ActiveSheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set SearchRange = .Range("B2:B" & LastRow) 'Search for TRUE in column B
Set cell = SearchRange.Find(what:=True, after:=SearchRange.Cells(1))
If Not cell Is Nothing Then
FirstFindAddress = cell.Address
Send_FWU_to_E_Drive cell.Offset(0, -1)
Do
Send_FWU_to_E_Drive cell.Offset(0, -1)
Set cell = SearchRange.FindNext(after:=cell)
Loop While Not cell Is Nothing And cell.Address <> FirstFindAddress
End If
End With
End Sub

Resources