I have a macro that loops through IDs and outputs the location including sheet name and then entire row where the value is found.
I also want to output the headers of the sheet where value is found above the entire row.
How would I modify my macro to accomplish this?
Sub findIDs2()
' findIDs2 Macro
' Once Parsed1 is run, run findIDs2 macro to output location and entire line where that Id is found.
'
Application.ScreenUpdating = False
Dim srcRng As Range, rng As Range, sAddr As String, fnd As Range, ws As Worksheet, x As Long: x = 1
Dim rngWs As Range
Set srcRng = Sheets("IDs").Range("A2", Sheets("IDs").Range("A" & Rows.Count).End(xlUp))
For Each rng In srcRng
For Each ws In Sheets
If ws.Name <> "IDs" And ws.Name <> "Results" Then
Set fnd = ws.Cells.Find(rng, LookIn:=xlValues, lookat:=xlPart)
If Not fnd Is Nothing Then
sAddr = fnd.Address
Do
With Sheets("Results")
.Range("A" & x) = fnd
.Range("B" & x) = fnd.Address
.Range("C" & x) = ws.Name
Set rngWs = Intersect(fnd.EntireRow, fnd.CurrentRegion)
rngWs.Copy
.Range("D" & x).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
x = x + 1
End With
Set fnd = ws.Cells.FindNext(fnd)
Loop While fnd.Address <> sAddr
sAddr = ""
End If
End If
Next ws
Next rng
Application.ScreenUpdating = True
End Sub
Related
Tried doing a search tool to the excel sheet (VBA) I'm working on.
So far every time I search for the text, it ends up filtering only the first row and not any row that has the value I'm looking for. I added a picture to show what it returns and the code as well. Is there anything I need to change to the code to make it search for all the data in the sheet instead of having it to show only one row? Any help is appreciated.
Search result of only the first row:
Sub SearchAllSheets()
Dim ws As Worksheet, OutputWs As Worksheet
Dim rFound As Range
Dim strName As String
Dim count As Long, LastRow As Long
Dim IsValueFound As Boolean
IsValueFound = False
Set OutputWs = Worksheets("sheet1") '---->change the sheet name as required
LastRow = OutputWs.Cells(Rows.count, "A").End(xlUp).Row
On Error Resume Next
strName = InputBox("What are you looking for?")
If strName = "" Then Exit Sub
For Each ws In Worksheets
If ws.Name <> "Output" Then
With ws.UsedRange
Set rFound = .Find(What:=strName, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
If Not rFound Is Nothing Then
Application.Goto rFound, True
IsValueFound = True
'MsgBox rFound.Row
rFound.EntireRow.Copy
OutputWs.Cells(LastRow + 1, 1).PasteSpecial xlPasteAll
Application.CutCopyMode = False
LastRow = LastRow + 1
End If
End With
End If
Next ws
On Error GoTo 0
If IsValueFound Then
OutputWs.Select
MsgBox "Result pasted to Sheet Output"
Else
MsgBox "Value not found"
End If
End Sub
Try this:
Sub SearchAllSheets()
Dim ws As Worksheet, OutputWs As Worksheet
Dim rFound As Range, IsValueFound As Boolean
Dim strName As String
Dim count As Long, LastRow As Long
Set OutputWs = Worksheets("Output") '---->change the sheet name as required
LastRow = OutputWs.Cells(Rows.count, "A").End(xlUp).row
strName = Trim(InputBox("What are you looking for?"))
If strName = "" Then Exit Sub
For Each ws In Worksheets
If ws.Name <> OutputWs.Name Then
Debug.Print "Checking " & ws.Name
Set rFound = FindAll(ws.UsedRange, strName)
If Not rFound Is Nothing Then
Set rFound = rFound.EntireRow
count = rFound.Cells.count / Columns.count 'how many matched rows?
Debug.Print "Found " & count & " rows"
rFound.Copy OutputWs.Cells(LastRow + 1, 1)
LastRow = LastRow + count
IsValueFound = True
End If
End If
Next ws
If IsValueFound Then
OutputWs.Select
MsgBox "Result(s) pasted to Sheet " & OutputWs.Name
Else
MsgBox "Value not found"
End If
End Sub
'find all cells in range `rng` with value `val` and return as a range
Public Function FindAll(rng As Range, val As String) As Range
Dim rv As Range, f As Range
Dim addr As String
Set f = rng.Find(what:=val, After:=rng.Cells(rng.Cells.count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
If rv Is Nothing Then
Set rv = f
Else
Set rv = Application.Union(rv, f)
End If
Set f = rng.FindNext(After:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function
I'm using a button macro to copy a range, it's super simple:
Worksheets("SNOW").Range("C6:D18").Copy
Now, how would I modify this to say "Copy this range, but if the value in column D is blank, skip that row completely in the copy process"? Dealing with text, not numbers.
Thanks.
You'll have to use Union to create a range that contains only your select rows (if the value in column D is not blank):
Sub Test()
Dim rng As Range, i As Long
For i = 6 To 18
If Range("D" & i).Value <> "" Then
If rng Is Nothing Then
Set rng = Range("C" & i & ":D" & i)
Else
Set rng = Application.Union(rng, Range("C" & i & ":D" & i))
End If
End If
Next i
If Not rng Is Nothing Then
rng.Copy
End If
End Sub
You could filter and copy the filtered data:
Sub Copy_Filtered()
With ThisWorkbook.Worksheets("Snow")
If .FilterMode Then
.ShowAllData
End If
With .Range("A6:D18")
.AutoFilter Field:=4, Criteria1:="<>"
.Copy 'Destination:=ThisWorkbook.Worksheets("Blizzard").Range("A1")
End With
End With
End Sub
NB: Uncomment the Destination to paste the range to the Blizzard sheet.
You can copy each area separately.
Option Explicit
Sub foo()
Dim ws As Worksheet, r As Range, rCpy As Range
Dim rDest As Range
Set ws = Worksheets("SNOW")
With ws
Set r = .Range(.Cells(6, 4), .Cells(18, 4)).SpecialCells(xlCellTypeConstants)
Set rDest = .Cells(6, 10)
For Each rCpy In r.Areas
Set rCpy = rCpy.Offset(columnoffset:=-1).Resize(columnsize:=2)
rCpy.Copy rDest
Set rDest = rDest.Offset(rCpy.Rows.Count)
Next rCpy
End With
End Sub
Another method, which will work no matter what the contents of the source data:
Set ws = Worksheets("SNOW")
With ws
.Rows.Hidden = False
Set rDest = .Cells(1, 6)
Set r = .Range(.Cells(6, 4), .Cells(18, 4)).SpecialCells(xlCellTypeBlanks)
r.EntireRow.Hidden = True
Set r = .Range(.Cells(6, 3), .Cells(18, 4)).SpecialCells(xlCellTypeVisible)
.Rows.Hidden = False
r.Copy rDest
End With
I have source data which are not aligned to table.
I want to find text (e.g. Account), copy the two whole lines below the cell with the found text (Account) and paste them on a different Sheet. Then search down and do again until the data ends. Data should be pasted in the order it is reached.
The cell with word "Account" will be always in the column A. The search should be for the exact word "Account", because in the column can be cells which contain e.g. "Payer account".
This code shows me an error msg
"Run-time error 438 - object doesnt support this property or method"
Private Sub Search_n_Copy()
Dim LastRow As Long
Dim rng As Range, C As Range
With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched
' loop through all cells in column A and copy below's cell to sheet "Output_2"
For Each C In rng
If C.Value = "Account" Then
C.Offset(-1, 0).Copy C.Offset.OUTPUT_2(-7, -1) ' use offset to put value in sheet "Output_2", column E
End If
Next C
End With
End Sub
This post doesn't point out what the error in your original code is. Ron Rosenfeld has already covered that in the comment.
Here is another faster way (as compared to looping) which uses .Find/.FindNext to achieve what you want. It also doesn't copy the rows in a loop but copies in the end.
Private Sub Search_n_Copy()
Dim ws As Worksheet
Dim rngCopy As Range, aCell As Range, bcell As Range
Dim strSearch As String
strSearch = "Account"
Set ws = Worksheets("INPUT_2")
With ws
Set aCell = .Columns(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bcell = aCell
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Do
Set aCell = .Columns(1).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bcell.Address Then Exit Do
If rngCopy Is Nothing Then
Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2))
Else
Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.Row + 2)))
End If
Else
Exit Do
End If
Loop
Else
MsgBox SearchString & " not Found"
End If
'~~> I am pasting to Output sheet. Change as applicable
If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Output").Rows(1)
End With
End Sub
Screenshot
The codle would be like this. This code Use variant.
Private Sub Search_n_Copy()
Dim LastRow As Long
Dim rng As Range, C As Range
Dim vR(), n As Long, k As Integer, j As Integer
Dim Ws As Worksheet
With Worksheets("INPUT_2") ' <-- here should be the Sheet's name
.Columns("e").ClearContents
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set rng = .Range("A1:A" & LastRow) ' set the dynamic range to be searched
' loop through all cells in column A and copy below's cell to sheet "Output_2"
For Each C In rng
If C.Value = "Account" Then
For j = 1 To 2
n = n + 1
ReDim Preserve vR(1 To 6, 1 To n)
For k = 1 To 6
vR(k, n) = C.Offset(j, k - 1) ' use offset to put value in sheet "Output_2", column E
Next k
End If
Next C
If n > 0 Then
Set Ws = Sheets.Add '<~~~ Sheets("your sheet name")
With Ws
.Range("a1").Resize(n, 6) = WorksheetFunction.Transpose(vR)
End With
End If
End With
End Sub
I need help modifying this code to match First and Last names across 2 worksheets, then remove matches from the Sub sheet. At the moment it only matches 2 columns across 1 sheet. Specifics:
How do i change this code so Names on 'Sheet 1' Column 'B' are Matched to names on 'sheet 2' column 'E' & all matches are deleted from 'Sheet 1". Same is repeated for 'Sheet 1' Column 'C' to 'Sheet 2' Column 'F'.
Sub CompareNames()
Dim rngDel As Range
Dim rngFound As Range
Dim varWord As Variant
Dim strFirst As String
With Sheets("ADULT Sign On Sheet")
For Each varWord In Application.Transpose(.Range("A1", .Cells(.Rows.Count,"A").End(xlUp)).Value)
If Len(varWord) > 0 Then
Set rngFound = .Columns("B").Find(varWord, .Cells(.Rows.Count, "B"), xlValues, xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
If Not rngDel Is Nothing Then Set rngDel = Union(rngDel, rngFound) Else Set rngDel = rngFound
Set rngFound = .Columns("B").Find(varWord, rngFound, xlValues, xlPart)
Loop While rngFound.Address <> strFirst
End If
End If
Next varWord
End With
If Not rngDel Is Nothing Then rngDel.Delete
Set rngDel = Nothing
Set rngFound = Nothing
End Sub
Loops through all values in Sheet1 Column B. If that value is found in Sheet2 Column E, the entire row in Sheet1 is deleted. Then it loops through all values in Sheet1 Column C. If that value is found in Sheet2 Column F, the entire row in Sheet1 is deleted.
Sub DeleteCopy()
Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
LastRow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
DestLast = Sheets("Sheet2").Range("E" & Rows.Count).End(xlUp).Row
For CurRow = 2 To LastRow 'Assumes your first row of data is in row 2
If Not Sheets("Sheet2").Range("E2:E" & DestLast).Find(Sheets("Sheet1").Range("B" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("Sheet1").Range("B" & CurRow).Value = ""
Else
End If
Next CurRow
LastRow = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
DestLast = Sheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Row
For CurRow = 2 To LastRow 'Assumes your first row of data is in row 2
If Not Sheets("Sheet2").Range("F2:F" & DestLast).Find(Sheets("Sheet1").Range("C" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("Sheet1").Range("C" & CurRow).Value = ""
Else
End If
Next CurRow
End Sub
Try this, you will have to call it twice once with the first criteria and then again with the second critiera
I think I have it set up properly for the first criteria
Sub DeleteIfMatchFound()
Dim SearchValues As Variant
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim sLR As Long, tLR As Long, i As Long
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
sLR = wsSource.Range("B" & wsSource.Rows.Count).End(xlUp).Row
tLR = wsTarget.Range("E" & wsSource.Rows.Count).End(xlUp).Row
SearchValues = wsSource.Range("B2:B" & sLR).Value
For i = 1 To (tLR - 1)
If Not IsError(Application.match(SearchValues(i, 1), wsTarget.Range("E2:E" & tLR), 0)) Then
wsTarget.Rows(i + 1).Delete
End If
Next i
End Sub
The workbook contains three sheets:
Item-style (contains in colA the item no., colB the style of the item)
Style (List of styles we want)
Style template (List of items within the styles specified in the cols)
I need a macro that does three things:
Copy the list of styles from the Style sheet and paste & transpose in Style template starting from row 2. Row 1 of all columns needs to be left blank.
The macro needs to select each style in style template one by one, which is now in different columns. These will be the search criteria.
On the basis of style selected in step 2, the macro needs to do a search in item-style sheet and select all the items that have the selected style and paste all these items beneath the corresponding style in style-template sheet. If there are no items corresponding to the selected style, then it should mention "No items" beneath the corresponding style.
Here's a link to the workbook for easy understanding
StyleProject
Though the workbook mentions only three styles the macro should have the capability of working with more than 50 styles.
Here's the code I have:
Sub StyleProject()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set ws = Sheets("Item-Style")
Set ws2 = Sheets("Style")
Set ws3 = Sheets("Style Template")
Dim rng As Range, secRng As Range
Dim i, j, k
Sheets("Style Template").Activate
finalcol = Cells(2, 50).End(x1toleft).Column
For i = 2 To finalcol
j = Cells(2, i).Value
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
For k = 2 To lr
Set rng = ws.Range("B" & i)
If StrComp(CStr(rng.Text), j, 1) = 0 Then
ws.Rows(k & ":" & k).Copy
nxtRow = ws3.Range(i & Rows.Count).End(xlUp).Row + 1
ws2.Rows(nxtRow & ":" & nxtRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Set rng = Nothing
End If
Next k
Next i
Application.ScreenUpdating = True
End Sub
It ends up in error trying to figure out nextrng I believe.
Sub StyleProject()
Dim wsStyle As Worksheet
Dim wsData As Worksheet
Dim wsTemplate As Worksheet
Dim StyleCell As Range
Dim rngFound As Range
Dim arrResults() As Variant
Dim strFirst As String
Dim ResultIndex As Long
Dim StyleIndex As Long
Set wsStyle = Sheets("Style")
Set wsData = Sheets("Item Data")
Set wsTemplate = Sheets("Style Template")
With wsStyle.Range("A2", wsStyle.Cells(Rows.Count, "A").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
ReDim arrResults(1 To 1 + Evaluate("MAX(COUNTIF(" & wsData.Columns("B").Address(External:=True) & "," & .Address(External:=True) & "))"), 1 To .Cells.Count)
For Each StyleCell In .Cells
StyleIndex = StyleIndex + 1
ResultIndex = 1
arrResults(ResultIndex, StyleIndex) = StyleCell.Text
Set rngFound = wsData.Columns("B").Find(StyleCell.Text, wsData.Cells(Rows.Count, "B"), xlValues, xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
ResultIndex = ResultIndex + 1
arrResults(ResultIndex, StyleIndex) = wsData.Cells(rngFound.Row, "A").Text
Set rngFound = wsData.Columns("B").Find(StyleCell.Text, rngFound, xlValues, xlWhole)
Loop While rngFound.Address <> strFirst
End If
Next StyleCell
End With
If UBound(arrResults, 1) > 1 Then
wsTemplate.Range("B2", wsTemplate.Cells(Rows.Count, Columns.Count)).Clear
wsTemplate.Range("B2").Resize(UBound(arrResults, 1), UBound(arrResults, 2)).Value = arrResults
With wsTemplate.Range("B2").Resize(, UBound(arrResults, 2))
.Font.Bold = True
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.EntireColumn.AutoFit
End With
End If
Set wsStyle = Nothing
Set wsData = Nothing
Set wsTemplate = Nothing
Set StyleCell = Nothing
Set rngFound = Nothing
Erase arrResults
End Sub