I have around 30 sheets that I want this code to run in at the same time. I want to find "ABC" and delete the value of the cell next to it in all my worksheets.
I get my error from: Set rSearch = .**range**("A1", .range("A" & rows.count).end(x1up))
When I have specified "Sheet1" next to the "With" statement, it works, but I want this code to run on all my sheets.
Sub soek()
Dim rSearch As Range
Dim rFound As Range
Dim sign12 As String
Dim sheetsarray As Sheets
Set sheetsarray = ActiveWorkbook.Sheets(Array("sheet1", "sheet2", "sheet3"))
sign12 = "ABC"
With sheetsarray
Set rSearch = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFound = rSearch.Find(What:=sign12, LookIn:=xlValues)
If rFound Is Nothing Then
Else
rFound.Offset(0, 1).ClearContents
End If
End With
End Sub
This question is a lot like: How to search for a string in all sheets of an Excel workbook?
But in my opinion, it's a lot easier to understand how to make code run on additional sheets reading my code than the code from the link above.
Try this (compilation of the comments above ;-)
Sub soek()
Dim rSearch As Range
Dim rFound As Range
Dim sign12 As String
Dim oWB As Workbook
Dim oWS As Worksheet
Set oWB = ThisWorkbook
sign12 = "ABC"
For Each oWS In oWB.Sheets
With oWS
Set rSearch = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFound = rSearch.Find(What:=sign12, LookIn:=xlValues)
If rFound Is Nothing Then
Else
rFound.Offset(0, 1).ClearContents
End If
End With
Next oWS
End Sub
Related
I have this code that loops all the sheets in my workbook and need to skip some of the sheets that will be hidden in my workbook by their codename
This is the code im using.
Dim WS As Worksheet
For Each WS In Worksheets
'Skips sheets below
example Skip .sheetscodename, .sheetscodename2, and so on
'Insert code to be looped here
Set Rng = WS.Range("C7", WS.Range("C1048576").End(xlUp))
For Each cel In Rng
If cel.Value = "0" Then
cel.EntireRow.Hidden = True
End If
Next cel
'Next sheet
Next WS
One method is to create a string of all the names to be skipped, then use InStr():
Dim WS As Worksheet
Dim cel As Range, Rng As Range
Dim shts As String
shts = ("sheetscodename,sheetscodename2,...")
For Each WS In Worksheets
If InStr(1, shts & ",", WS.CodeName & ",", vbTextCompare) = 0 Then
'Insert code to be looped here
Set Rng = WS.Range("C7", WS.Range("C1048576").End(xlUp))
For Each cel In Rng
If cel.Value = "0" Then
cel.EntireRow.Hidden = True
End If
Next cel
End If
'Next sheet
Next WS
I'm struggling with the following code which you can see below. It is totally a pain in the *** now. I really need some help.
This code is a search tool which looks for criteria from every worksheet except the summary and the list. After the .Find founds the word, then the code selects a 4 wide range around the searched word, then it copies and pastes it on the Summary sheet.
When the first searched word is found, I also would like to copy and paste the actual worksheet (where the word is found) title (on each worksheet "G3:J3") right after the search result on the summary page. This search tool could help me to find quickly which search criteria where can be found, at which sheet and some properties which also inside the title.
The result should look like this: (r1 = the first 4 columns, r2= the rest 4 columns (that is the excel header))
item nr. Item Owner Used Capacity ESD_nr. box Owner Free capacity location
Sorry for the long description.
CODE:
Private Sub searchTool()
Dim ws As Worksheet, OutputWs As Worksheet, wbName As Worksheet
Dim rFound As Range, r1 As Range, r2 As Range, multiRange As Range
Dim strName As String
Dim count As Long, lastRow As Long
Dim IsValueFound As Boolean
IsValueFound = False
Set OutputWs = Worksheets("Summary") '---->change the sheet name as required
lastRow = OutputWs.Cells(Rows.count, "K").End(xlUp).Row
On Error Resume Next
strName = ComboBox1.Value
If strName = "" Then Exit Sub
For Each ws In Worksheets
If ws.Name <> "lists" And ws.Name <> "Summary" Then
With ws.UsedRange
Set rFound = .Find(What:=strName, LookIn:=xlValues, LookAt:=xlWhole)
If Not rFound Is Nothing Then
firstAddress = rFound.Address
Do
IsValueFound = True
Set r1 = Range(rFound.EntireRow.Cells(1, "B"), rFound.EntireRow.Cells(1, "D"))
Set r2 = Range("G3:J3")
Set multiRange = Application.Union(r1, r2)
multiRange.Copy
OutputWs.Cells(lastRow + 1, 11).PasteSpecial xlPasteAll
Application.CutCopyMode = False
lastRow = lastRow + 1
Set rFound = .FindNext(rFound)
Loop While Not rFound Is Nothing And rFound.Address <> firstAddress
End If
End With
End If
Next ws
On Error GoTo 0
If IsValueFound Then
OutputWs.Select
MsgBox "Seach complete!"
Else
MsgBox "Name not found!"
End If
End Sub
I must admit I had trouble following your requirements and there was not a definition of where it wasn't working, to that end I re-wrote it to help me understand.
Private Sub SearchTool_2()
Dim BlnFound As Boolean
Dim LngRow As Long
Dim RngFind As Excel.Range
Dim RngFirstFind As Excel.Range
Dim StrName As String
Dim WkShtOutput As Excel.Worksheet
Dim WkSht As Excel.Worksheet
StrName = "Hello" 'ComboBox1.Value
If StrName = "" Then Exit Sub
Set WkShtOutput = ThisWorkbook.Worksheets("Summary")
LngRow = WkShtOutput.Cells(WkShtOutput.Rows.count, "K").End(xlUp).Row + 1
For Each WkSht In ThisWorkbook.Worksheets
If (WkSht.Name <> "lists") And (WkSht.Name <> "Summary") Then
With WkSht.UsedRange
Set RngFind = .Find(What:=StrName, LookIn:=xlValues, LookAt:=xlWhole)
If Not RngFind Is Nothing Then
Set RngFirstFind = RngFind
BlnFound = True
Do
WkSht.Range(RngFind.Address & ":" & WkSht.Cells(RngFind.Row, RngFind.Column + 2).Address).Copy WkShtOutput.Range(WkShtOutput.Cells(LngRow, 11).Address)
WkSht.Range("G3:J3").Copy WkShtOutput.Range(WkShtOutput.Cells(LngRow + 1, 11).Address)
LngRow = LngRow + 2
Set RngFind = .FindNext(RngFind)
Loop Until RngFind.Address = RngFirstFind.Address
End If
End With
End If
Next
Set WkShtOutput = Nothing
If BlnFound Then
ThisWorkbook.Worksheets("Summary").Select
MsgBox "Seach complete!"
Else
MsgBox "Name not found!"
End If
End Sub
I found the copy statement was the better option rather than using the clipboard, I also found a missing reference of firstAddress.
I have three ranges in a sheet (rng1, rng2, rng3) where I need to make sure that rng2 and rng3 contain no blanks before proceeding with the macro.
I have tried several methods that I can find and cannot get any of them to work. Willing to try a different method if someone has suggestions.
This is me trying to count blank cells using specialcells(xlCellTypeBLanks) but something isn't working with my error handling when neither range is blank:
Dim wrk As Workbook
Dim sht As Worksheet
Dim twb As Workbook
Dim tws As Worksheet
Dim lrow As Long
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim finprod As Variant
Dim subprod As Variant
Application.ScreenUpdating = False
Set wrk = ActiveWorkbook
Set sht = wrk.Worksheets(1)
For Each sht In wrk.Worksheets
lrow = sht.Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = sht.Range("A2:A" & lrow)
Set rng2 = sht.Range("F2:F" & lrow)
Set rng3 = sht.Range("E2:E" & lrow)
On Error GoTo Err1
If rng3.SpecialCells(xlCellTypeBlanks).Count > 0 Then
MsgBox ("Invalid item number.")
Exit Sub
End If
Err1:
On Error GoTo Err2
If rng2.SpecialCells(xlCellTypeBlanks).Count > 0 Then
MsgBox ("Missing quantity.")
Exit Sub
End If
Err2:
On Error GoTo 0
Exit For
Next sht
I try to avoid using goto in such way - it makes the code confusing when it gets bigger. Here is what I came up with:
Sub check_blank()
Dim sht As Worksheet
Dim twb As Workbook
Dim tws As Worksheet
Dim lrow As Long
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim finprod As Variant
Dim subprod As Variant
Application.ScreenUpdating = False
Set wrk = ActiveWorkbook
Set sht = wrk.Worksheets(1)
For Each sht In wrk.Worksheets
lrow = sht.Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = sht.Range("A2:A" & lrow)
Set rng2 = sht.Range("F2:F" & lrow)
Set rng3 = sht.Range("E2:E" & lrow)
If Application.CountIf(rng3, "") > 0 Then
MsgBox ("Invalid item number.")
Exit Sub
End If
If Application.CountIf(rng2, "") > 0 Then
MsgBox ("Missing quantity.")
Exit Sub
End If
Next sht
End Sub
The Range.SpecialCells method is Nothing when there are no xlCellTypeBlanks cells available and Nothing does not have a count; not even a count of zero.
You can use the On Error Resume Next or choose a non-destructive method of determining if there are blank cells.
if cbool(application.countblank(rng2)) then
'there are zero-length string and/or blank cells
'do something
end if
The problem with the above is that the worksheet's COUNTBLANK function will count zero-length strings returned by a formula (e.g. "") as blanks when they are not truly blank.
To catch only truly blank cells the following will be True - CBool(rng2.Count - application.Countif(rng2, "<>")). Only truly blank cells will be counted and any non-zero count will be true. This avoids having to crash the environment with On Error Resume Next when there is nothing to find.
I am having an issue creating a macro that will autofill a VBA function named "FindMyOrderNumber". Every time I run a macro to Autofill "FindMyOrderNumber" only the first cell in the column is populated.
This function will look up an order number in column A (A1) and return the name of the worksheet it can be found B (B1).
Option Explicit
Function FindMyOrderNumber(strOrder As String) As String
Dim ws As Worksheet
Dim rng As Range
For Each ws In Worksheets
If ws.CodeName <> "Sheet3" Then
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.Find(What:=strOrder, LookAt:=xlWhole)
On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = ws.Name
Exit For
End If
End If
Next
Set rng = Nothing
Set ws = Nothing
End Function
I created this macro to enter my VBA function "=findmyordernumber(a1)" in cell B1 then to Autofill column B.
Sub AutofillVBAFunction()
Range("B1").Select
ActiveCell.FormulaR1C1 = "=FindMyOrderNumber(RC[-1])"
Selection.Autofill Destination:=Range("B1:B68")
Range("B1:B68").Select
End Sub
After I run this macro only B1 is populated.
Sorry if this has been discussed I am new and I tried How to fill-up cells within a Excel worksheet from a VBA function? and other questions and I could not apply it to my issue.
Please help
Add application.volatile to the function, that way it will calculate as the sheet changes.
Function FindMyOrderNumber(strOrder As String) As String
Dim ws As Worksheet
Dim rng As Range
Application.Volatile
For Each ws In Worksheets
If ws.CodeName <> "Sheet3" Then
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.Find(What:=strOrder, LookAt:=xlWhole)
On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = ws.Name
Exit For
End If
End If
Next
Set rng = Nothing
Set ws = Nothing
End Function
It also wouldn't hurt to calculate the sheet when You add the formula to the range.
Sub Button1_Click()
Dim Rws As Long, Rng As Range
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(Cells(1, 2), Cells(Rws, 2))
Rng = "=FindMyOrderNumber(RC[-1])"
End Sub
I have compiled a code that searches for a value in a excel file say for example that value is 'D0'. When i tested the Search code separately it worked. But, when i combine my search code with a code that loops through files it does not work . The problem found is that the search does not returns the value.I have pointed out in the code, the Part thats not working. All, I am trying to do is to combine a search code with a code which will pick up file names written in the column of an excel sheet and then open those files and execute the search code.
Sub MyMacro()
Dim MyCell, Rng As Range
Dim Fname As String
Dim FirstAddress As String
Set Rng = Sheets("Sheet1").Range("A1:A6") 'sets the range to Read from
For Each MyCell In Rng 'checks each cell in range
If MyCell <> "" Then 'Picks up the file name present in the cell
MyCell.Activate 'Activates the cell
Fname = ActiveCell.Value 'Assigns the value of the cell to fname
Application.ScreenUpdating = False
Set wb = Workbooks.Open("C:\Users\" & Fname, True, True)
'opens the file
wb.Worksheets("Sheet1").Activate 'activates the opened workbook
Call Find_String 'calls the search code
wb.Close SaveChanges:=False
End If
Next
End Sub
Sub Find_String()
Dim FirstAddress As String
Dim MySearch As Variant
Dim Rng As Range
Dim I As Long
Dim strMyValu
Dim Axis
Dim wb As Workbook
MySearch = Array("D0") 'value that needs to be searched
Set wb = ActiveWorkbook 'trying to bring the opened workbook as active sheet
With Sheets("Sheet1").Range("B1:H100")
For I = LBound(MySearch) To UBound(MySearch)
Set Rng = .Find(What:=MySearch(I), _After:=.Cells(.Cells.Count), _LookIn:=xlFormulas, _
LookAt:=xlWhole, _SearchOrder:=xlByRows, _SearchDirection:=xlNext, _MatchCase:=False)
If Not Rng Is Nothing Then 'this is the part not working
'It should return the search value instead it returns nothing
'so as the value returned by the code is nothing and hence the code goes to endif
FirstAddress = Rng.Address
Do
Sheets("Sheet1").Select 'Selecting sheet1 on opened file
Rng.Activate
strMyValue = ActiveCell.Offset(0, 6).Value 'Copying the offset value of the located cell
Axis = ActiveCell.Offset(0, 3).Value
Workbooks("book22.xlsx").Worksheets("Sheet2").Activate
'Activating the workbook where i want to paste the result
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = strMyValue
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Axis
wb.Activate
'Activating the opened file again for loop to search for more values
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End Sub
Kindly help.
I am struck. I am new to VBA. So, unable to figure out what went wrong as when i tested the search code seperately it worked. Is it something related to the activation of file opened?
When i open a file it is not activated and hence search runs on the workbook that contains the macro instead of the opened file and so its unable to return search value???
Thank you
Part of your problem is the naming of your variables and the changing workbook and worksheet contexts. Be specific in you naming of variables so that you know what it should be and it will help you debug.
Also you don't need to activate workbooks and worksheets to get values from the ranges and cells. just getting a reference to the sheet,range cell will allow you to get what you need.
See it this does the trick for you.
Option Explicit
Sub MyMacro()
Dim MyCell, Rng As Range
Dim Fname As String
Dim FirstAddress As String
Dim searchSheet As Worksheet
Dim copyToSheet As Worksheet
Dim copyToWorkbook As Workbook
Dim searchWorkbook As Workbook
Set copyToWorkbook = Workbooks.Open("C:\Temp\workbook22.xlsx")
Set copyToSheet = copyToWorkbook.Worksheets("Sheet2")
Set Rng = Sheets("Sheet1").Range("A1:A6") 'sets the range to Read from
For Each MyCell In Rng 'checks each cell in range
If MyCell <> "" Then 'Picks up the file name present in the cell
Fname = MyCell.Value 'Assigns the value of the cell to fname
Set searchWorkbook = Workbooks.Open("C:\Temp\" & Fname, True, True)
Set searchSheet = searchWorkbook.Worksheets("Sheet1") 'get a reference to the sheet to be searched
Find_String searchSheet, copyToSheet 'calls the search code with the referenece sheet
searchWorkbook.Close SaveChanges:=False
End If
Next
copyToWorkbook.Close True
End Sub
Sub Find_String(searchSheet As Worksheet, copyToSheet As Worksheet)
Dim FirstAddress As String
Dim MySearch As Variant
Dim Rng As Range
Dim I As Long
Dim strMyValue As String
Dim Axis
Dim foundCell As Range
MySearch = Array("D0") 'value that needs to be searched
With searchSheet.Range("B1:H100")
For I = LBound(MySearch) To UBound(MySearch)
Set Rng = .Find(What:=MySearch(I), After:=.Cells(.Cells.Count), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not Rng Is Nothing Then 'this is the part not working
'It should return the search value instead it returns nothing
'so as the value returned by the code is nothing and hence the code goes to endif
FirstAddress = Rng.Address
Do
strMyValue = Rng.Offset(0, 6).Value 'Copying the offset value of the located cell
Axis = Rng.Offset(0, 3).Value
copyToSheet.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = strMyValue
copyToSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Axis
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End Sub
Agreed with Nathan.
Also, always avoid Application.ScreenUpdating = False with mix of ActiveWorkbook, ActiveSheet, ActiveCell.
Your Find_String should reference the object instead of just range of the activeworkbook
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value
Set oWSResult = Workbooks("book22.xlsx").Worksheets("Sheet2")
oWSResult.Range("B" & ...
It is hard to debug if you presume the active objects are always the one you are after.
Here's a revamped version of the code. This should run more quickly, and the FindAll function is a bit more versatile.
Sub MyMacro()
Dim wbDest As Workbook
Dim wsDest As Worksheet
Dim wsFileNames As Worksheet
Dim DataBookCell As Range
Dim rngCopy As Range
Dim CopyCell As Range
Dim arrData(1 To 65000, 1 To 2) As Variant
Dim MySearch As Variant
Dim varFind As Variant
Dim BookIndex As Long
Dim DataIndex As Long
Set wbDest = ActiveWorkbook
Set wsFileNames = wbDest.Sheets("Sheet1")
Set wsDest = wbDest.Sheets("Sheet2")
MySearch = Array("D0")
For Each DataBookCell In wsFileNames.Range("A1", wsFileNames.Cells(Rows.Count, "A").End(xlUp)).Cells
If Len(Dir("C:\Users\" & DataBookCell.Text)) > 0 And Len(DataBookCell.Text) > 0 Then
With Workbooks.Open("C:\Users\" & DataBookCell.Text)
For Each varFind In MySearch
Set rngCopy = FindAll(varFind, .Sheets(1).Range("B1:H100"))
If Not rngCopy Is Nothing Then
For Each CopyCell In rngCopy.Cells
DataIndex = DataIndex + 1
arrData(DataIndex, 1) = CopyCell.Offset(, 3).Value
arrData(DataIndex, 2) = CopyCell.Offset(, 6).Value
Next CopyCell
End If
Next varFind
.Close False
End With
End If
Next DataBookCell
If DataIndex > 0 Then wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(DataIndex, UBound(arrData, 2)).Value = arrData
Set wbDest = Nothing
Set wsFileNames = Nothing
Set wsDest = Nothing
Set DataBookCell = Nothing
Set rngCopy = Nothing
Set CopyCell = Nothing
Erase arrData
If IsArray(MySearch) Then Erase MySearch
End Sub
Public Function FindAll(ByVal varFind As Variant, ByVal rngSearch As Range, _
Optional ByVal LookIn As XlFindLookIn = xlValues, _
Optional ByVal LookAt As XlLookAt = xlWhole, _
Optional ByVal MatchCase As Boolean = False) As Range
Dim rngAll As Range
Dim rngFound As Range
Dim strFirst As String
Set rngFound = rngSearch.Find(varFind, rngSearch.Cells(rngSearch.Cells.Count), LookIn, LookAt, MatchCase:=MatchCase)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Set rngAll = rngFound
Do
Set rngAll = Union(rngAll, rngFound)
Set rngFound = rngSearch.Find(varFind, rngFound, LookIn, LookAt, MatchCase:=MatchCase)
Loop While rngFound.Address <> strFirst
Set FindAll = rngAll
Else
Set FindAll = Nothing
End If
Set rngAll = Nothing
Set rngFound = Nothing
End Function