In my VBA code below it searches for any cell for red to delete. The line is at
Dim colors_to_delete As String: colors_to_delete = "red"
What would I add to this code so it delete red and blue?
Sub collapse_columns()
Dim x As Integer
For x = 1 To 4
collapse_column x
Next
End Sub
Sub collapse_column(column_number As Integer)
Dim row As Long
Dim s As Worksheet
Dim last_row As Long
Set s = ActiveSheet ' work on the active sheet
'Set s = Worksheets("Sheet1") 'work on a specific sheet
last_row = s.Cells(s.Rows.Count, column_number).End(xlUp).row
Dim colors_to_delete As String: colors_to_delete = "red"
For row = last_row To 1 Step -1
If InStr(1, " " & s.Cells(row, column_number).Value & " ", " " & colors_to_delete & " ") > 0 Then
s.Cells(row, column_number).Delete xlUp
End If
Next row
End Sub
You could use an array of color names:
Sub collapse_column(column_number As Integer)
Dim row As Long
Dim s As Worksheet
Dim last_row As Long, clr, c as Range
Set s = ActiveSheet ' work on the active sheet
last_row = s.Cells(s.Rows.Count, column_number).End(xlUp).row
For row = last_row To 1 Step -1
Set c = s.Cells(row, column_number)
For Each clr in Array("red", "blue") '<< array to check against
If InStr(1, " " & c.Value & " ", " " & clr & " ") > 0 Then
c.Delete xlUp
Exit For 'stop checking
End If
Next clr
Next row
End Sub
Related
I get a mismatch error in this line :
row_str = Join(cell_rng, Chr(10))
Thank you. I am intermediate.
I attached a piece of the code below:
Dim last_row As String
Dim last_col As String
Dim office_str As String
Dim lookupVal As String
Dim i As Long
Dim seperate_cells, cell_rng As Range
Dim r As Range
Dim row_str As String
With Contacts
For i = 2 To last_row
Set cell_rng = Rows(i & ":" & i + 1)
For Each r In cell_rng.Rows
seperate_cells = cellsSeparator(r.SpecialCells(xlCellTypeConstants))
If row_str = "" Then
row_str = Join(cell_rng, Chr(10))
Else
row_str = row_str & vbLf & Join(cell_rng, Chr(10))
End If
Next
Debug.Print row_str
Client_Finder.result.Text = Client_Finder.result.Text & vbLf & row_str
Next i
End With
````
Please try the next way. It will place the values of the necessary specific row in the text box, each value separated by " | ":
Sub testSeparatorsBetweenRowCells()
'your existing code...
Dim arr, rngR As Range
For i = 2 To last_row
lookupVal = cells(i, office_str)
' Compare ComboBox with the range from the spreadsheet
If lookupVal = Office_Code Then
Set rngR = rows(i & ":" & i).SpecialCells(xlCellTypeConstants) 'Set a range which will return all cells value in the row, except the empty ones
arr = arrCells(rngR) 'call a function able to make an array from the range set in the above line
Client_Finder.result.Text = Client_Finder.result.Text & vbLf & Join(arr, " | ") 'add the text obtained by joining the array to the next line of existing text
End If
Next i
End Sub
Function arrCells(rng As Range) As Variant
Dim arr, Ar As Range, i As Long, C As Range
ReDim arr(rng.cells.count - 1) 'ReDim the array to be filled as the range cells number.
'- 1, because the array is 0 based...
For Each Ar In rng.Areas 'iterate between the range areas
For Each C In Ar.cells 'iterate between cells of each area
arr(i) = C.value: i = i + 1 'put each cell value in the array
Next
Next
arrCells = arr 'make the function returning the arr
End Function
If the text in the text box still goes on the next line, try making the text box property WordWrap False. If you cannot see all the text, make the textbox wider or decrease its font size.
Please, test it and send some feedback.
Edited:
Please, try understanding the next piece of code, able to deal with copying more rows at once:
Sub testCopyingMoreRows()
Dim sh As Worksheet, i As Long, rng As Range, r As Range, arr, strRow As String
Set sh = ActiveSheet
i = 9
Set rng = sh.rows(i & ":" & i + 1)
'you ca select cells, rows (even not consecutive) and use:
'Set rng = Selection.EntireRow 'just uncomment this code line...
'extract rows and paste their contents (exept the empty cells) in Imediate Window
For Each r In rng.rows
arr = arrCells(r.SpecialCells(xlCellTypeConstants))
If strRow = "" Then
strRow = Join(arr, " | ")
Else
strRow = strRow & vbLf & Join(arr, " | ")
End If
Next
Debug.Print strRow
'instead returning in Imediate Window, you can do it in your text box (uncomment the next line):
'Client_Finder.result.Text = Client_Finder.result.Text & vbLf & strRow
End Sub
The code uses the same function arrCells...
New to asking questions on this site, and to VBA so please bear with me... I'm compiling this database that is linking drawing numbers that show the same items but each drawing shows a different aspect of that particular 'area' shown in the drawing (I Hope that makes sense). The function that i would like to have is to be able to search just the A column for a value, and return the all of the unique times that the value shows up in the A column and the corresponding B column value. I thought that even with my paltry VBA skills i could manage this but I dont have much so far. This is what i have:
Dim ISO As String
Dim Rng As Range
ISO = InputBox("ISO Number: ", "Enter ISO Number")
If Trim(ISO) <> "" Then
With Sheets("Sheet1").Range("A:A")
Set Rng = .Find(What:=ISO)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox ("Nothing Found")
End If
End With
End If
Thanks in Advance.
I'd use a for loop to iterate over the cells.
Sub FindMatches()
Dim ISO As String
Dim Rng As Range
Dim lastRow As Long, x As Long
Dim ws As Worksheet
Dim foundCount As Long
Dim endString As String
ISO = InputBox("ISO Number: ", "Enter ISO Number")
If Trim(ISO) <> "" Then
Set ws = Sheets("Sheet1") ' always best to use a variable for an object if possible
lastRow = ws.Cells(100000, 1).End(xlUp).Row ' work out how many rows to loop through
For x = 1 To lastRow ' use a for loop to iterate over each row
If ws.Cells(x, 1) = ISO Then
foundCount = foundCount + 1
endString = endString & ws.Cells(x, 2) & vbNewLine ' add column B to the string
End If
Next x
End If
MsgBox "Found " & foundCount & " matches: " & vbNewLine & endString
End Sub
For faster processing you could use an array rather than read from the cells one at at time:
Sub FindMatchesArray()
Dim ISO As String
Dim Rng As Range
Dim lastRow As Long, x As Long
Dim ws As Worksheet
Dim foundCount As Long
Dim endString As String
Dim arr() As Variant
ISO = InputBox("ISO Number: ", "Enter ISO Number")
If Trim(ISO) <> "" Then
Set ws = Sheets("Sheet1") ' always best to use a variable for an object if possible
lastRow = ws.Cells(100000, 1).End(xlUp).Row ' work out how many rows to loop through
arr = ws.Range("A1:B" & lastRow).Value
For x = 1 To lastRow ' use a for loop to iterate over each row
If arr(x, 1) = ISO Then
foundCount = foundCount + 1
endString = endString & arr(x, 2) & vbNewLine ' add column B to the string
End If
Next x
End If
MsgBox "Found " & foundCount & " matches: " & vbNewLine & endString
End Sub
You could use Find and FindNext.
The first Test will return the values in a message box, the second will place the returned values in cell A1 on Sheet2.
I could've sworn this should work as a Worksheetfunction, but no luck (.FindNext won't work in a UDF).
Sub Test()
Dim MyMessage As String
MyMessage = ReturnCountAndValue("5", ThisWorkbook.Worksheets("Sheet1").Columns(1))
MsgBox MyMessage, vbOKOnly + vbInformation
End Sub
Sub Test2()
With ThisWorkbook
.Worksheets("Sheet2").Range("A1") = ReturnCountAndValue(.Worksheets("Sheet1").Range("K2"), _
.Worksheets("Sheet1").Range("F2:F9"))
End With
End Sub
Public Function ReturnCountAndValue(SearchValue As String, _
SearchColumn As Range) As String
Dim rFound As Range
Dim sFirstAddress As String
Dim sTempReturn As String
Dim lCounter As Long
With SearchColumn
Set rFound = .Find(What:=SearchValue, LookIn:=xlValues, LookAt:=xlWhole)
If Not rFound Is Nothing Then
sFirstAddress = rFound.Address
Do
lCounter = lCounter + 1
sTempReturn = sTempReturn & rFound.Offset(, 1).Value & vbCr
Set rFound = .FindNext(rFound)
Loop While rFound.Address <> sFirstAddress
sTempReturn = lCounter & " items found. " & vbCr & _
sTempReturn
Else
sTempReturn = SearchValue & " not found in range " & SearchColumn.Address
End If
End With
ReturnCountAndValue = sTempReturn
End Function
I am looking for a code, that can find each cell that starts with the number "2347" in column L. I want to get the cell adresses for these cells and display it in a MessageBox for example "Msgbox: Cells L3500:L3722 has a value starts starts with "2347" "
Sub Findrow()
Dim MyVal As Integer
Dim LastRow As Long
MyVal = LEFT(c.Value,4) = "2347" _
LastRow = Cells(Rows.Count, "L").End(xlUp).Row
For Each c In Range("L2:L" & LastRow)
If c.Value = Myval Then
This is my code so far. Hope someone can help me!
Using arrays is quite fast
Option Explicit
Public Sub FindIDInColL()
Const VID = "2347" 'Value to find
Dim ws As Worksheet, arrCol As Variant, found As Variant
Set ws = ActiveSheet 'Or Set ws = ThisWorkbook.Worksheets("Sheet3")
arrCol = ws.Range(ws.Cells(2, "L"), ws.Cells(ws.Rows.Count, "L").End(xlUp))
ReDim found(1 To UBound(arrCol))
Dim r As Long, f As Long, msg As String
f = 1
For r = 1 To UBound(arrCol) 'Iterate vals in col L, excluding header row
If Not IsError(arrCol(r, 1)) Then 'Ignore errors
If Len(arrCol(r, 1)) > 3 Then 'Check only strings longer than 3 letters
If Left$(arrCol(r, 1), 4) = VID Then 'Check first 4 letters
found(f) = r + 1 'Capture rows containing value (header offset)
f = f + 1
End If
End If
End If
Next
If f > 1 Then 'If any cells found
ReDim Preserve found(1 To f - 1) 'Drop unused array items
msg = "Cells in col L starting with """ & VID & """" & vbNewLine & vbNewLine
MsgBox msg & " - L" & Join(found, ", L"), , "Total Found: " & f - 1
Else
MsgBox "No cells starting with """ & VID & """ found in col L", , "No matches"
End If
End Sub
Even faster when using the string versions of these functions
Left$() Mid$() Right$() Chr$() ChrW$() UCase$() LCase$()
LTrim$() RTrim$() Trim$() Space$() String$() Format$()
Hex$() Oct$() Str$() Error$
They are more efficient (if Null is not a concern), as pointed out by QHarr
You may try this:
Option Explicit
Sub Findrow()
Dim MyVal As String ' "2347" is a String
Dim LastRow As Long
Dim c As Range, myCells As Range
MyVal = "2347"
LastRow = cells(Rows.Count, "L").End(xlUp).row
Set myCells = Range("M2") 'initialize cells with a dummy cell certainly out of relevant one
For Each c In Range("L2:L" & LastRow)
If Left(c.Value2, 4) = MyVal Then Set myCells = Union(myCells, c) ' if current cell matches criteria then add it to cells
Next
If myCells.Count > 1 Then MsgBox "Cells " & Intersect(myCells, Range("L:L")).Address(False, False) & " have values starting with ‘2347’" ' if there are other cells than the dummy one then get rid of this latter and show their addresses
End Sub
I have two excel sheet ReportOld and ReportNew, what I want to check and make sure all the column herder from both sheets are matching name and in same order. Basically need to check there should not be any new column added or removed from last report.. bot are identical.
Till now I tried the code is:
Sub colLookup()
Dim ShtOne As Worksheet, ShtTwo As Worksheet
Dim shtOneHead As Range, shtTwoHead As Range
Dim headerOne As Range, headerTwo As Range
Dim x As Integer
Dim lastCol As Long
Set ShtOne = Sheets("ReportOld")
Set ShtTwo = Sheets("ReportNew")
lastCol = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtOneHead = ShtOne.Range("A1", ShtOne.Cells(1, lastCol))
lastCol = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtTwoHead = ShtTwo.Range("A1", ShtTwo.Cells(1, lastCol))
For Each headerTwo In shtTwoHead
For Each headerOne In shtOneHead
If headerTwo.Value = headerOne.Value Then
Else
x = MsgBox("Headers are not matching in both sheets.")
MsgBox "value is:" & headerTwo.Value
Exit Sub
End If
Next headerOne
Next headerTwo
End Sub
Try this code. It counts the headings on both sheets and fills an array of headings from both sheets. Then it compares the headings one each sheet and displays a message if the headings don't match. It then compares the number of columns and if they don't match, another message is displayed...
Sub colLookup()
Dim ShtOne As Worksheet, ShtTwo As Worksheet
Dim shtOneHead As Range, shtTwoHead As Range
Dim headerOne As Range, headerTwo As Range
Dim x As Integer
Dim lastCol As Long
Set ShtOne = Sheets("ReportOld")
Set ShtTwo = Sheets("ReportNew")
lastCol = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtOneHead = ShtOne.Range("A1", ShtOne.Cells(1, lastCol))
lastCol = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtTwoHead = ShtTwo.Range("A1", ShtTwo.Cells(1, lastCol))
For Each headerTwo In shtTwoHead
For Each headerOne In shtOneHead
If headerTwo.Value = headerOne.Value Then
Else
x = MsgBox("Headers are not matching in both sheets.")
MsgBox "value is:" & headerTwo.Value
Exit Sub
End If
Next headerOne
Next headerTwo
End Sub
Sub new_code()
Dim a As Integer
Dim b As Integer
Dim x As Integer
Dim HeadNew As Integer
Dim HeadOld As Integer
Dim HeadingsNew() As String
Dim HeadingsOld() As String
a = 1
b = 1
HeadNew = 0
HeadOld = 0
Erase HeadingsNew
Erase HeadingsOld
Worksheets("ReportNew").Activate
Do Until Len(Trim(Cells(1, a))) = 0
DoEvents
ReDim Preserve HeadingsNew(1 To a)
HeadingsNew(a) = Trim(Cells(1, a))
a = a + 1
Loop
a = a - 1
HeadNew = a
Worksheets("ReportOld").Activate
Do Until Len(Trim(Cells(1, b))) = 0
DoEvents
ReDim Preserve HeadingsOld(1 To b)
HeadingsOld(b) = Trim(Cells(1, b))
b = b + 1
Loop
b = b - 1
HeadOld = b
x = 1
Do Until x > a
DoEvents
If HeadingsNew(x) <> HeadingsOld(x) Then
MsgBox " Headings are different" & Chr(10) & Chr(10) & _
" column number " & x & Chr(10) & _
" ReportNew: " & (HeadingsNew(x)) & Chr(10) & _
" ReportOld: " & (HeadingsOld(x)), vbCritical, "Data Issue"
End If
x = x + 1
Loop
If HeadOld <> HeadNew Then
MsgBox " The number of headings don't match", vbcritacal, "Data Issue"
End If
End Sub
I suggest a variant array. Here is a simple solution.
Sub Compare()
Dim header1 As Variant, header2 As Variant, i as long
header1 = sheets("ReportOld").Rows(1).Value
header2 = sheets("ReportNew").Rows(1).Value
For i = 1 To 100000
If header1(1, i) <> vbNullString Then
If header1(1, i) <> header2(1, i) Then
MsgBox "Compare Failed at column " & i
Exit For
End If
Else
MsgBox "Compare ="
Exit For
End If
Next i
End Sub
I have the following VBA code:
Sub test():
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2"): Set w2 = Sheets("Sheet3")
GetNameValue: For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).row
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1: Do Until w1.Range("A" & j) = "DATE OF BIRTH:": j = j + 1: Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1: End If
GetNext: Next i: NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|"): j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1): w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
To break down what this code does:
1) Set the first sheet that should be searched and the second sheet (output sheet) that the results should be appended to.
2) Search the first column for a certain string "NAME:" and once found take the value in the second column, place it in the output sheet go look for "DATE OF BIRTH:". Once "DATE OF BIRTH:" is found put it beside the value for "NAME:" in the output sheet.
3) Repeat until there are no more entries.
I'm sure this is a very simple modification, but what I'd like to do is check whether a certain string exists, if it does grab the entry directly BELOW it, and then continue searching for the next string and associated entry just like the code does already.
Can anyone point me to what I would need to change in order to do this (and preferably why)?
In addition, how might I be able to extend this code to run over multiple sheets while depositing the results in a single sheet? Do I need to set up a range running over the worksheets w_1....w_(n-1) (with output sheet w_n possibly in a different workbook)?
Removed Line continuations in code:
Sub test()
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
GetNameValue:
For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1
Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
j = j + 1
Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1
End If
GetNext:
Next i
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1)
w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
UPDATE: Just to make sure we're all on the same page about what the output would look like. Suppose we are searching for the entry below A and the entry beside C:
INPUT
A 1
B
y 3
z 4
t
d
s 7
C 8
A 1
Z
y 3
z 4
t
d
s 7
C 12
OUTPUT
B 8
Z 12
.
.
.
Assuming I understand your desire correctly, you can use the .Offset method with your current range to get to the cell below it. You would need to add a dim, so here's my stab at what you're trying to accomplish:
Sub test()
Dim NameValue As String, w1 As Worksheet, w2 As Worksheet
'new local variable
Dim newValue as string
Dim i As Long, j As Long, k As Long, c As Long
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
GetNameValue:
For i = 1 To w1.Range("A" & Rows.Count).End(xlUp).Row
'assuming your string is in column A
If w1.Range("A" & i) = "FIND ME" Then
newValue = w1.Range("A" & i).Offset(1,0).Value
End If
If w1.Range("A" & i) = "NAME:" Then
If InStr(1, NameValue, w1.Range("B" & i)) Then GoTo GetNext
j = i + 1
Do Until w1.Range("A" & j) = "DATE OF BIRTH:"
j = j + 1
Loop
NameValue = Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
c = c + 1
End If
GetNext:
Next i
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
w2.Range("A" & k) = Left(NameValue, i - 1)
w2.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
Then you could do anything you desired with the newValue string, including putting it in w2 like so: w2.Range("D1").value = newValue
UPDATED ANSWER
I am now 89% sure I know what you are trying to accomplish :) thanks for your clarifying example.
To search a range for your search string, you need to set up a range you are looking in:
dim searchRange as range
dim w1,w2 as worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
set searchRange = w1.Range("A" & Rows.Count).End(xlUp).Row
Then you search the searchRange for both of your search strings (which I'm saying are "A" for the first and "C" for the second). As long as both strings are found in the searchRange, it will create a new Dictionary entry for the two values, having the value below "A" as the key and the value beside "C" as the item.
dim rng as range
dim valueBelowFirstSearch as string
dim resultsDictionary as object
dim i as integer
dim c, d as range
dim cAddress, dAddress as string
set resultsDictionary = CreateObject("scripting.dictionary")
with searchRange
set c = .Find("A", lookin:=xlValues)
set d = .Find("C", lookin:=xlValues)
if not c Is Nothing and not d Is Nothing then
cAddress = c.address
dAddress = d.address
resultsDictionary.add Key:=c.offset(1,0).value, Item:=d.value
Do
set c = .FindNext(c)
set d = .FindNext(d)
Loop While not c is nothing and not d is nothing and c.address <> cAddress and d.address <> dAddress
end if
end with
Now that we have all of the results in the resultsDictionary, we can now output the values into another place, which I'm choosing to be w2.
dim outRange as range
dim item as variant
set outRange = w2.Range("A1")
for each item in resultsDictionary
outRange.Value = item.key
set outRange = outRange.Offset(0,1)
outRange.Value = item.item
set outRange = outRange.Offset(1,-1)
next item
Can anyone point me to what I would need to change in order to do this
(and preferably why)?
Basically you need to change the parts of which NameValue is composed.
Originally you took the value beside the first match as w1.Range("B" & i) and now you want the value below the first match, which is w1.Range("A" & i + 1).
Originally it was:
Trim(NameValue & " " & w1.Range("B" & i) & "|" & w1.Range("B" & j))
Now you need something like this:
Trim(NameValue & " " & w1.Range("A" & i + 1) & "|" & w1.Range("B" & j))
In addition, how might I be able to extend this code to run over
multiple sheets while depositing the results in a single sheet?
(with output sheet w_n possibly in a different workbook)?
To achieve that you can e.g. create an array of Sheets and let the code run for each Sheet of this array. Note that the array might contain 1-N Sheets.
' Set array of sheets for just one sheet
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1"))
' Set array of sheets for more sheets, e.g. "Sheet1" and "Sheet2" and "Sheet3"
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2", "Sheet3"))
' Finally set the second sheet where the results should be appended
' to sheet in the same workbook as the searched sheets
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeBook.xlsx").Worksheets("ResultSheet")
' Or set the second sheet where the results should be appended to sheet
' in a different workbook then the searched sheets belong to
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")
The complete code might look like this (tested with data you provided).
Option Explicit
Public Sub main()
' String to search below of it
Dim string1 As String
string1 = "A"
' String to search beside of it
Dim string2 As String
string2 = "C"
' Set the sheets that should be searched
Dim searchedSheets As Sheets
Set searchedSheets = Workbooks("SomeBook.xlsx").Sheets(Array("Sheet1", "Sheet2"))
' Set the second sheet (outputSheet sheet) that the results should be
' appended to external sheet in different book
Dim outputSheet As Worksheet
Set outputSheet = Workbooks("SomeOtherBook.xlsx").Worksheets("ResultSheet")
SearchFor string1, string2, searchedSheets, outputSheet
End Sub
Public Sub SearchFor( _
string1 As String, _
string2 As String, _
searchedSheets As Sheets, _
output As Worksheet)
Dim searched As Worksheet
Dim NameValue As String
Dim below As String
Dim beside As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim c As Long
Dim rowsCount As Long
For Each searched In searchedSheets
rowsCount = searched.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To rowsCount
' Search the first column for a 'string1'
If searched.Range("A" & i) = string1 Then
' once 'string1' was found grab the entry directly below it
below = searched.Range("A" & i + 1)
If InStr(1, NameValue, below) Then
' skip this 'below' result because it was found before
GoTo GetNext
End If
' Search the first column for a 'string2' starting at the
' position where 'below' was found
For j = i + 1 To rowsCount
If searched.Range("A" & j) = string2 Then
' once 'string2' was found grab the entry directly
' beside it
beside = searched.Range("B" & j)
Exit For
End If
Next j
' Append 'below' and 'beside' to the result and count the
' number of metches
NameValue = Trim(NameValue & " " & below & "|" & beside)
c = c + 1
End If
GetNext:
Next i
Next searched
' Write the output
NameValue = NameValue & " "
For k = 1 To c
i = InStr(1, NameValue, "|")
j = InStr(i, NameValue, " ")
output.Range("A" & k) = Left(NameValue, i - 1)
output.Range("B" & k) = Mid(NameValue, i + 1, j - i)
NameValue = Mid(NameValue, j + 1, Len(NameValue) - j)
Next k
End Sub
Note: I replaced the Do-Until loop with For-Next loop because the Do-Until might cause a Stack-Overflow :-) error if the string "DATE OF BIRTH:" does not exist in the first column. However I have tryied to keep your originall code structure so you still understand it. HTH.
Assuming that you want to find one value (Name:), then continue searching till to find the second one (Date Of Birth:)... Finally, you want to move these pair of data into another worksheet.
To achieve that, i'd suggest to use Dictionary object to get only distinct values. I strongly do not recommend to use string concatenation as you provided in your code!
Option Explicit
Sub Test()
Dim src As Worksheet, dst As Worksheet
Set dst = ThisWorkbook.Worksheets("Sheet2")
For Each src In ThisWorkbook.Worksheets
If src.Name = dst.Name Then GoTo SkipNext
NamesToList src, dst
SkipNext:
Next
End Sub
'needs reference to MS Scripting Runtime library
Sub NamesToList(ByVal srcWsh As Worksheet, ByVal dstWsh As Worksheet, _
Optional ByVal SearchFor As String = "NAME:", Optional ByVal ThenNextFor As String = "DATE OF BIRTH:")
Dim dic As Dictionary, i As Long, j As Long, k As Long
Dim sKey As String, sVal As String
On Error GoTo Err_NamesToList
Set dic = New Dictionary
i = 2
j = GetFirstEmpty(srcWsh)
Do While i < j
If srcWsh.Range("A" & i) = SearchFor Then
sKey = srcWsh.Range("B" & i)
If Not dic.Exists(sKey) Then
Do While srcWsh.Range("A" & i) <> ThenNextFor
i = i + 1
Loop
sVal = srcWsh.Range("B" & i)
dic.Add sKey, sVal
k = GetFirstEmpty(dstWsh)
With dstWsh
.Range("A" & k) = sKey
.Range("B" & k) = sVal
End With
'sKey = ""
'sVal = ""
End If
End If
SkipNext:
i = i + 1
Loop
Exit_NamesToList:
On Error Resume Next
Set dic = Nothing
Exit Sub
Err_NamesToList:
Resume Exit_NamesToList
End Sub
Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function
Sample output:
Name DateOfBirth:
A 1999-01-01
B 1999-01-02
C 1999-01-03
D 1999-01-04
E 1999-01-05