I am trying to search for all cells containing a specific string value. If possible multiple strings e.g.
"TextText*" that would find "123Text123Text123"
within a given range and return an ID reference from that row.
I managed to use an "If Cell.Value = xxx" scenario however this only looks for exact matches rather than containing:
intMyVal = InputBox("Please enter Sales Order No.")
lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
newrow = 1
For Each Cell In Range("D2:D" & lngLastRow) 'Data to search
If Cell.Value = intMyVal Then
Cells(Cell.Row, 1).Copy 'Copy ID1 value
Sheets("TempData").Cells(newrow, 1).PasteSpecial xlPasteValues 'Paste ID1 value in temp data
newrow = newrow + 1
End If
Next Cell
The below images shows an extract of the data. Column D would be searched for specific text strings (e.g. "Tesco" or "Ireland") and for each hit, the corresponding value in column A would be copied to a temporary data page.
Rather than look at each cell use FIND and FINDNEXT:
Public Sub FindSales()
Dim sValToFind As String
Dim rSearchRange As Range
Dim sFirstAdd As String
Dim rFoundCell As Range
Dim rAllFoundCells As Range
Dim sMessage As String
sValToFind = InputBox("Please enter Sales Order No.")
'Code to check a valid number entered
'.
'.
With ThisWorkbook.Worksheets("Sheet1")
Set rSearchRange = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With rSearchRange
Set rFoundCell = .Find(sValToFind, LookIn:=xlValues, LookAt:=xlPart)
If Not rFoundCell Is Nothing Then
sFirstAdd = rFoundCell.Address
Do
sMessage = sMessage & rFoundCell.Row & ", "
'Create a range of found cells.
If Not rAllFoundCells Is Nothing Then
Set rAllFoundCells = Union(rAllFoundCells, rFoundCell)
Else
Set rAllFoundCells = rFoundCell
End If
Set rFoundCell = .FindNext(rFoundCell)
Loop While rFoundCell.Address <> sFirstAdd
End If
End With
rAllFoundCells.Copy Destination:=ThisWorkbook.Worksheets("Sheet2").Range("A1")
sMessage = sValToFind & " found on rows " & Mid(sMessage, 1, Len(sMessage) - 2) & "."
MsgBox sMessage, vbOKOnly + vbInformation
End Sub
Solution is simple: use Like operator: If someCell.Value Like "*Text*Text*" Then would do exactly what you want.
In your case I suppose it would be:
If Cell.Value Like "*" & intMyVal & "*" Then
Related
I am working to create an add on style sheet to my company timesheet that will autofill company paid holidays by just the user inserting the dates. I use formulas on the excel timesheets to autofill the dates for the entire year so that I save time doing my bi-weekly payroll form. I have a holiday sheet that I name the holidays and input the date they are observed. The code is supposed to search all worksheets in the workbook until it finds the date for the corresponding holiday and input the number of hours off, the holiday code and name. The code I have written will find any date I insert up to 11/9/2022 and after this date it will not find any further dates. I have tried many things including changing the date column format, using different criteria settings for the .Find and even removing the formula from the date column and actually writing in 11/11/2022 and it is still unable to locate the date while using .Find. Please any help would be appreciated. I have added a few screens and code snippets of what I have so far.
Sub VeteransDay()
Dim ws As Worksheet
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Holiday").Range("B9").Value
If Trim(FindString) <> "" Then
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
With ws.UsedRange
Set Rng = .Find(What:=FindString, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
If Not Rng Is Nothing Then
sheetName = ws.Name
Cell_Add = Split(Rng.Address, "$")
ThisCol = Cell_Add(1)
ThisRow = Cell_Add(2)
Worksheets(sheetName).Range("K" & ThisRow).Value = 8
Worksheets(sheetName).Range("K" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("L" & ThisRow).Value = "HD"
Worksheets(sheetName).Range("L" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("M" & ThisRow).Value = Range("A9")
Worksheets(sheetName).Range("M" & ThisRow).Font.Color = vbRed
Exit Sub
End If
End With
End If
Next ws
End If
End Sub
enter image description here
enter image description here
Try this, the search is restricted to the range B1:B37 on each sheet.
Option Explicit
Sub VeteransDay()
Dim ws As Worksheet, ar, r
Dim dt As Date, sName As String, n As Long
Dim arHoliday, lastrow As Long, i As Long
With Sheets("Holiday")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
arHoliday = .Range("A1:B" & lastrow).Value
End With
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
' loop through holidays
For i = 1 To UBound(arHoliday)
dt = arHoliday(i, 2)
r = Application.Match(CDbl(dt), ws.Range("B1:B37").Value2, 0)
If Not IsError(r) Then
'MsgBox ws.Name & " row " & r
With ws.Range("K" & r)
.Value = 8
.Offset(, 1) = "HD"
.Offset(, 2) = arHoliday(i, 1) ' col A
.Resize(, 3).Font.Color = vbRed
n = n + 1
End With
End If
Next
End If
Next ws
MsgBox n & " found for all dates", vbInformation
End Sub
The problem I'm stuck with is as follows. I'm trying to cut "Price and Date" from an import page into a new table based on numerous criteria. I have a Specification sheet where I compare what those criteria have to be.
On the import page I have 3 criteria that have to be fulfilled first of all (these change based on the users input:
These are compared to a table which looks as follows: (This table doesn't change much. At most Origin and Key might be updated, or another row might be added)
For every line where Fruit, Type and Color match we have to look at another factor. Whether or not the fruit was bought from the "supermarket" or "farmer". On the import sheet we have the following table which changes every month.
When the fruit is bought at the Supermarket I want to use the correct key that corresponds with the row that fulfills the right criteria for "Fruit", "Type" and "Color". So in this example above I would like to use the key that corresponds with "Apple", "Fresh", "Red". Which in this example is just the first row. The corresponding key is "Supermarket ID 1" of which we have several rows of data in the import table. I would like to cut and paste the "Price" and "Date" from these rows into a new table.
For those fruits bought from the farmer it's a little different because 1) The comparable key is in a different column than the supermarket one and 2) The key is just a piece of the whole string of the import page (this is always the case). Here too I would like to cut the "Price" and "Date" into a different table.
Hopefully someone understands the problem. The code I've written so far is as follows:
Sub Fruits1()
Dim Criteria1 As Variant, Criteria2 As Variant, Criteria3 As Variant, Criteria4 As Variant, Criteria5 As Variant
Dim rng As Range, cell As Range
Dim wsImport As Worksheet: Set wsImport = Sheets("Import")
Dim wsSpec As Worksheet: Set wsSpec = Sheets("Specificaties")
Dim primarykey As String, comparingkey As String
Criteria1 = wsImport.Range("C3")
Criteria2 = wsImport.Range("C4")
Criteria3 = wsImport.Range("C5")
Set rng = wsSpec.Range("H3:H" & (wsSpec.Cells(Rows.Count, 8).End(xlUp).Row))
For Each cell In rng
If cell.Value = Criteria1 And cell.Offset(0, 1).Value = Criteria2 And cell.Offset(0, 2).Value = Criteria3 Then
If cell.Offset(0, 3) = "Supermarket" Then
import_lastrow = wsImport.Range("E" & Rows.Count).End(xlUp).Row
For i = import_lastrow To 2 Step -1
primarykey = cell.Offset(0, 4).Value
comparingkey = wsImport.Cells(i, 13).Value
If InStr(primarykey, comparingkey) > 0 Then
MsgBox "cut Price and Data into new table"
End If
Next i
ElseIf cell.Offset(0, 4) = "Farmer" Then
For i = import_lastrow To 2 Step -1
primarykey = cell.Offset(0, 4).Value
comparingkey = wsImport.Cells(i, 8).Value
If InStr(primarykey, comparingkey) > 0 Then
MsgBox "cut Price and Data into new table"
End If
Next i
End If
End If
Next cell
End Sub
The problem I believe lies in that I'm trying to loop through different ranges and not doing it right.
Logic:
Use .Find and .Findnext to search for 1st criteria. It is much faster than looping through every cell and matching the first criteria
Once you have your "Supermarket/Farmer" use Autofilter on the relevant column to identify and copy the relevant rows.
After copying, delete the unnecessary columns (if you wish)
Code:
Ok is this what you are trying? (UNTESTED). I quickly wrote this. Let me know if you get any errors?
Option Explicit
Dim wsImport As Worksheet
Sub Sample()
Dim wsSpec As Worksheet
Set wsImport = ThisWorkbook.Sheets("Import")
Set wsSpec = ThisWorkbook.Sheets("Specificaties")
Dim CriteriaA As String, CriteriaB As String, CriteriaC As String
Dim aCell As Range, bCell As Range
Dim origin As String, KeyToFind As String
With wsSpec
CriteriaA = .Range("C3").Value2
CriteriaB = .Range("C4").Value2
CriteriaC = .Range("C5").Value2
'~~> Using .Find to look for CriteriaA
Set aCell = .Columns(8).Find(What:=CriteriaA, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> Check if found or not
If Not aCell Is Nothing Then
Set bCell = aCell
'~~> Secondary checks
If aCell.Offset(, 1).Value2 = CriteriaB And _
aCell.Offset(, 2).Value2 = CriteriaC Then '<~~ If match found
'~~> Get the origin and the key
origin = aCell.Offset(, 3).Value2
KeyToFind = aCell.Offset(, 4).Value2
Else '<~~ If match not found then search for next match
Do
Set aCell = .Columns(8).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
If aCell.Offset(, 1).Value2 = CriteriaB And _
aCell.Offset(, 2).Value2 = CriteriaC Then
origin = aCell.Offset(, 3).Value2
KeyToFind = aCell.Offset(, 4).Value2
Exit Do
End If
Else
Exit Do
End If
Loop
End If
'~~> Check the origin
If origin = "Supermarket" Then
CopyRows "F", KeyToFind, False
ElseIf origin = "Farmer" Then
CopyRows "H", KeyToFind, True
Else
MsgBox "Please check origin. Supermarket/Farmer not found. Exiting..."
End If
Else
MsgBox "Criteria A match was not found. Exiting..."
End If
End With
End Sub
'~~> Autofilter and copy filtered data
Private Sub CopyRows(Col As String, SearchString As String, PartialString As Boolean)
Dim copyFrom As Range
Dim lRow As Long
With wsImport
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range(Col & .Rows.Count).End(xlUp).Row
With .Range(Col & "1:" & Col & lRow)
If PartialString = False Then
.AutoFilter Field:=1, Criteria1:=SearchString
Else
.AutoFilter Field:=1, Criteria1:="=*" & SearchString & "*"
End If
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
'~~> Some sheet where you want to paste the output
Dim SomeSheet As Worksheet
Set SomeSheet = ThisWorkbook.Sheets("Output")
If Not copyFrom Is Nothing Then
'~~> Copy and paste to some sheet
copyFrom.Copy SomeSheet.Rows(1)
'After copying, delete the unwanted columns (OPTIONAL)
End If
End Sub
I have a list of words in Sheet1 I need to match one by one from Sheets("Sheet2").Range("A1:A7500") until the end of the Range. Whenever word is matched I need to do something with it in Sheet1. That word occurs multiple times in Sheets("Sheet2").Range("A1:A7500").
Following code is Finding word only once. I dont understand where it is going wrong.
Sub XMAX()
Dim lrow As Long
Dim cel As Range
Dim oRng As Range: Set oRng = Sheets("Sheet2").Range("A1:A7500")
Dim oFoundRng As Range, oLastRng As Range
lrow = Sheets("sheet1").Cells(Sheets("Sheet1").Rows.Count, "f").End(xlUp).Row
'''''''''''''''Sheet1'''''''''''''''
For Each cel In Range("f4:f" & lrow)
If IsEmpty(cel.Value) = False Then
Set oFoundRng = oRng.find(cel.Value)
Do While Not oFoundRng Is Nothing
If UCase(oFoundRng.Offset(0, 1).Value) = "ISAAC" Then
Range("X" & cel.Row).Value = "X"
ElseIf UCase(oFoundRng.Offset(0, 1).Value) = "YO" Then
Range("V" & cel.Row).Value = "X"
ElseIf UCase(oFoundRng.Offset(0, 1).Value) = "JAN" Then
Range("U" & cel.Row).Value = "X"
Else
MsgBox oFoundRng.Value
End If
Set oLastRng = oFoundRng
Set oFoundRng = oRng.FindNext(cel.Value) 'Getting Error(1004) here "unable to get findnext property of the range class"
If oLastRng >= oFoundRng Then
Exit Do
End If
Loop
Else
End If
Next
Change this line
Set oFoundRng = oRng.FindNext(oFoundRng)
to
Set oFoundRng = oRng.FindNext
You are not searching for the word but for the range you previously found. You actually don't need to pass a value to .FindNext at all.
You also have to change this line
If oLastRng >= oFoundRng Then
to
If oLastRng.Row >= oFoundRng.Row Then
since the first line compares the values (which is not what you want to do since it will always evaluate to True). You actually want to compare the row numbers.
On another note, the following code snippet does not work:
If UCase(oFoundRng.Offset(0, 1).Value) = "ISAAC" Then
Range("X" & cel.Row).Value = "X"
ElseIf UCase(oFoundRng.Offset(0, 1).Value) = "ISAAC" Then
Range("W" & cel.Row).Value = "X"
This ElseIf will never be triggered since the condition is the same as the initial If condition.
You also don't need both of these statements:
Set oFoundRng = Nothing
Exit Do
They both achieve the same thing (breaking the loop), Exit Do does it more efficiently.
you may be after this (explanations in comments):
Sub XMAX()
Dim cel As Range
Dim oRng As Range: Set oRng = Sheets("Sheet2").Range("A1:A7500")
Dim oFoundRng As Range
Dim firstAddress As String
With Sheets("sheet1") ' reference "Sheet1" sheet
With .Range("f4", .Cells(.Rows.Count, "f").End(xlUp)) ' reference referenced sheet column "F" range from row 4 down to last not empty one
If WorksheetFunction.CountA(.Cells) > 0 Then ' if there's at least one not empty cell
For Each cel In .SpecialCells(xlCellTypeConstants) ' loop through referenced range not empty cells
Set oFoundRng = oRng.Find(what:=cel.Value, LookIn:=xlValues, lookat:=xlWhole) ' always specify at least 'LookIn' and 'LookAt' parameters, or they will be set as per last 'Find()' usage (even from Excel UI!)
If Not oFoundRng Is Nothing Then ' if a match found
firstAddress = oFoundRng.Address ' store first matched cell address
Do
Select Case UCase(oFoundRng.Offset(0, 1).Value2)
Case "ISAAC"
.Range("X" & cel.Row).Value = "X"
Case "YO"
.Range("V" & cel.Row).Value = "X"
Case "JAN"
.Range("U" & cel.Row).Value = "X"
Case Else
MsgBox oFoundRng.Value
End Select
Set oFoundRng = oRng.FindNext(oFoundRng) ' search for next occurrence
Loop While oFoundRng.Address <> firstAddress ' exit do when hitting fisr found cell again
End If
Next
End If
End With
End With
End Sub
I've got a sample table in Sheet1 as below:
Location Model Part #
BF03 200W 40536573
BF04 200W 40536573
CV01 120W 40536585
CV02 135W 20085112
CV03 900W 20349280
CV04 135W 20085112
As a reference data of BF03 is in cell B6.
What I need it to do is:
A) When user typed part number (ex: 40536573) in Sheet3 say cell A1, only the matched location will be picked up
B) The picked up "location" value will be tabulated in Sheet2 starting from cell A6.
The output will look something like this:
Location Model Part #
BF03 200W 40536573
BF04 200W 40536573
To make matter more complicated, I would then need to have the "Location" data to be concatenated into a string and store it in Sheet 2 Cell A2.
I'm guessing we need to do a For Loop count rows but I couldn't get any reference on how to write it properly.
Below are what my error "OVERFLOW" code looks like
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim FindMatch As String
Dim Rng As Range
Dim counter As Integer
counter = ActiveWorkbook.Worksheets("Sheet2").Range("A6", Worksheets("Sheet2").Range("A6").End(xlDown)).Rows.Count
For i = 6 To counter
'Get the value from other sheet set as FindMatch
FindMatch = Sheets("Sheet3").Cell("A1").Value
'Find each row if matches the desired FindMatch
If Trim(FindMatch) <> "" Then
With Sheets("Sheet2").Range("D" & i).Rows.Count
Set Rng = .Find(What:=FindMatch, _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
'copy the values required to the cell
Cells(i, 2) = Sheets("Sheet2").Cells(Rng.Row, 2)
Else
MsgBox "Nothing found"
End If
End With
End If
Next i
End Sub
Instead of using the .find method, I managed to use a simple for loop. Sometimes you need to think simple i guess :) I have also added a small function to clear previously used fields. If you check and give feedback if you face any problem, we can try to fix it.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim S_Var As String
Dim copyRange As Range
Dim ws1_lastrow As Long
Dim ws2_lastrow As Long
Dim searchresult As Range
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set ws3 = Sheets("Sheet3")
S_Var = ws3.Range("A1").Value
ws1_lastrow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
Set copyRange = ws1.Range("A1:C" & ws1_lastrow)
'Clear Data
ws2.Range("A2").Value = ""
If Range("A7").Value <> "" Then
ws2.Range("A7:C" & ws2.Range("A" & ws1.Rows.Count).End(xlUp).Row).Value = ""
End If
'Searchin through the sheet1 column1
For i = 2 To ws1_lastrow
If ws1.Range("C" & i) = S_Var Then
ws2_lastrow = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
ws1.Range("A" & i & ":C" & i).Copy Destination:=ws2.Range("A" & ws2_lastrow + 1)
End If
Next
'Adding location to sheet2 A2 as string
ws2_lastrow = ws2.Range("A" & ws1.Rows.Count).End(xlUp).Row
For i = 7 To ws2_lastrow 'starting from 7, where location starts
If ws2.Range("A2").Value = "" Then
ws2.Range("A2").Value = ws2.Range("A" & i).Value
Else
ws2.Range("A2").Value = ws2.Range("A2").Value & "," & ws2.Range("A" & i).Value
End If
Next
Update: sample file sample workbook
Problem: I would like to have something that can automatically
1. Search for the part number and revision. After the cell which contains "PART NUMBER" and "REVISION" is found, I need to get the values of below two cell (offset 1 column).
2. It will continue to look for the summary table
3. Put the summary table to a result sheet
4. Continue searching and repeat the process
There are:
Possible of multiple parts number on the same sheet or just 1
Only searching for the Sheet with starting name: "Search"
First Picture shows the structure of the file and the Second Picture shows the result
This will help a lot if it is doable. Please help me.
Update 1:
Logic as I think:
1. Write a module to search for all sheets starting with name "SEARCH"
Go to each sheet resulted from step 1 - to search .NEXT for PART NUMBER and REVISION to get all part number name and revision (addressing by offset(0,1))
Start to search for the summary table ==> It gets to complicated point
Wow, this takes me back to the days when I had to do this nasty stuff a lot!
Anyway, I wrote some code that gets what you want. I may have taken a different approach than you may have thought, but I think it's kind of similar.
Assumptions
PART NUMBER is always in Column B
REVISION is always in Column F
Double check all other references against your original data. I could not access your workbook (due to my work office security), so I made my own book up based on your screenshots).
Option Explicit
Sub wowzer()
Dim wks As Worksheet, wksResult As Worksheet
'set up results sheet
Set wksResult = Worksheets.Add(After:=Worksheets(Worksheets.Count))
With wksResult
.Name = "Results"
.Range("A1:F1") = Array("Part", "Rev", "Name", "Category", "TotalA", "TotalB")
End With
'loop through sheets to get data over
For Each wks In Worksheets
If Left(wks.Name, 6) = "Search" Then ' does sheet start with search?
With wks
Dim rngFindPart As Range, rngFindName As Range
Set rngFindPart = .Columns(2).Find("PART NUMBER", lookat:=xlWhole, After:=.Range("B" & .Rows.Count))
Set rngFindName = .Columns(2).Find("NAME", lookat:=xlWhole, After:=.Range("B" & .Rows.Count))
Dim strFrstAdd As String
strFrstAdd = rngFindPart.Address 'used as a check for when we loop back and find first "PART NUMBER" again
If Not rngFindPart Is Nothing Or Not rngFindName Is Nothing Then
'not going to do anything if no PART NUMBER or NAME found
Do
Dim rngMove As Range
'copy table and place it in result sheet
Set rngMove = .Range(rngFindName.Offset(1).Address, rngFindName.End(xlToRight).End(xlDown))
rngMove.Copy wksResult.Range("C" & wksResult.Rows.Count).End(xlUp).Offset(1)
'place part and revision, aligned with table (will de-duplicate later)
With wksResult
.Range(.Range("A" & .Rows.Count).End(xlUp).Offset(1), .Range("A" & .Rows.Count).End(xlUp).Offset(2)) = rngFindPart.Offset(1)
.Range(.Range("B" & .Rows.Count).End(xlUp).Offset(1), .Range("B" & .Rows.Count).End(xlUp).Offset(2)) = rngFindPart.Offset(1, 4)
End With
'find next instance of "PART NUMBER" and "NAME"
Set rngFindPart = .Columns(2).Find("PART NUMBER", lookat:=xlWhole, After:=rngFindPart)
Set rngFindName = .Columns(2).Find("NAME", lookat:=xlWhole, After:=rngFindPart)
'done when no part number exists or it's the first instance we found
Loop Until rngFindPart Is Nothing Or rngFindPart.Address = strFrstAdd
End If
End With
End If
Next
'de-duplicate results sheet
With wksResult
'if sheet is empty do nothing
If .Cells(2, 1) <> vbNullString Then
.UsedRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes
End If
End With
End Sub
Is this what you are trying?
CODE
Option Explicit
Const SearchString As String = "PART NUMBER"
Dim wsO As Worksheet, WsI1 As Worksheet, WsI2 As Worksheet
Dim lRow As Long
Sub Sample()
Set wsO = Sheets("Result")
Set WsI1 = Sheets("SEARCH PAGE1")
Set WsI2 = Sheets("SEARCH PAGE2")
lRow = 2
PopulateFrom WsI1
PopulateFrom WsI2
End Sub
Sub PopulateFrom(ws As Worksheet)
Dim aCell As Range, bCell As Range, cCell As Range, nmRng As Range, cl As Range
Dim i As Long
Dim ExitLoop As Boolean
With ws
Set aCell = .Cells.Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
wsO.Range("A" & lRow).Value = aCell.Offset(1).Value
wsO.Range("B" & lRow).Value = aCell.Offset(1, 3).Value
i = 1
Do
If aCell.Offset(i) = "NAME" Then
Set nmRng = .Range(aCell.Offset(i), aCell.Offset(i).End(xlDown))
For Each cl In nmRng
If cl.Value <> "NAME" Then
If wsO.Range("A" & lRow).Value = "" Then
wsO.Range("A" & lRow).Value = wsO.Range("A" & lRow - 1).Value
wsO.Range("B" & lRow).Value = wsO.Range("B" & lRow - 1).Value
End If
wsO.Range("C" & lRow).Value = cl.Value
wsO.Range("D" & lRow).Value = cl.Offset(, 1).Value
wsO.Range("E" & lRow).Value = cl.Offset(, 2).Value
wsO.Range("F" & lRow).Value = cl.Offset(, 3).Value
lRow = lRow + 1
End If
Next
Exit Do
End If
i = i + 1
Loop
Do While ExitLoop = False
Set aCell = .Cells.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
wsO.Range("A" & lRow).Value = aCell.Offset(1).Value
wsO.Range("B" & lRow).Value = aCell.Offset(1, 3).Value
i = 1
Do
If aCell.Offset(i) = "NAME" Then
Set nmRng = .Range(aCell.Offset(i), aCell.Offset(i).End(xlDown))
For Each cl In nmRng
If cl.Value <> "NAME" Then
If wsO.Range("A" & lRow).Value = "" Then
wsO.Range("A" & lRow).Value = wsO.Range("A" & lRow - 1).Value
wsO.Range("B" & lRow).Value = wsO.Range("B" & lRow - 1).Value
End If
wsO.Range("C" & lRow).Value = cl.Value
wsO.Range("D" & lRow).Value = cl.Offset(, 1).Value
wsO.Range("E" & lRow).Value = cl.Offset(, 2).Value
wsO.Range("F" & lRow).Value = cl.Offset(, 3).Value
lRow = lRow + 1
End If
Next
Exit Do
End If
i = i + 1
Loop
Else
ExitLoop = True
End If
Loop
End If
End With
End Sub
SAMPLE FILE
i.minus.com/1338702873/20yZJWFxgv9Egtd4klNOBg/dtst1Y4ckv86f/Sample.xlsm