I have what is working code but I want to be able to run it 2,3, 4 times and have it just keep moving down the destination sheet. Instead it overwrites what the last pass pasted.
Sub Comparison_Entry()
Dim myWord$
myWord = InputBox("Enter UID, If no more UIDs, enter nothing and click OK", "Enter User")
If myWord = "" Then Exit Sub
Application.ScreenUpdating = False
Dim xRow&, NextRow&, LastRow&
NextRow = 1
LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For xRow = 1 To LastRow
If WorksheetFunction.CountIf(Rows(xRow), "*" & myWord & "*") > 0 Then
Rows(xRow).Copy Sheets("Sheet1").Rows(NextRow)
NextRow = NextRow + 1
End If
Next xRow
Application.ScreenUpdating = True
MsgBox "Copyng complete, " & NextRow - 2 & " rows containing" & vbCrLf & _
"''" & myWord & "''" & " were copied to Sheet1.", 64, "Done"
End Sub``
I tried adding a loop to this but each pass through it would start over at the top of Sheet1. Similarly, if I simply call the Sub again I get the same result.
Normally you would know what column to search through, such as what column is UID. in this example code I will assume it is column A of the active sheet, change the column letter to what suites you.
Sub Comparison_EntryB()
Dim Rws As Long, rng As Range, c As Range
Dim ws As Worksheet, sh As Worksheet, s As String
Set ws = ActiveSheet
Set sh = Sheets("Sheet1")
With ws
Rws = .Cells(.Rows.Count, "A").End(xlUp).Row 'change to column you need you search through
Set rng = .Range(.Cells(1, "A"), .Cells(Rws, "A")) 'change to column you need to search through
End With
s = InputBox("enter Something")
For Each c In rng.Cells
If UCase(c) Like "*" & UCase(s) & "*" Then
c.EntireRow.Copy sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1)
End If
Next c
End Sub
Related
I am trying to find any cells with just spaces in. When I run this though it finds cells that are blanks too. Is there anyway to just find cells with spaces?
For i = 1 to lastRow
If len(trim(this workbook.sheets("data").range("a" & i)) = 0 then
Msgbox("a" & i " contains only space")
End if
Next i
Plase, try:
Sub testFindSpaces()
Dim wsD as Worksheet, i As Long, x As String, lastRow As Long
Set wsD = ThisWorkbook.Sheets("data")
lastRow = wsD.Range("A" & wsD.rows.count).End(xlUp).row
For i = 1 To lastRow
x = wsD.Range("a" & i).Value
If UBound(Split(x, " ")) = Len(x) Then
MsgBox "a" & i & " contains only space"
End If
Next i
End Sub
Just exclude blanks by testing for Len(ThisWorkbook.Worksheets("data").Range("A" & i)) <> 0 too.
For i = 1 to lastRow
Dim Untrimmed As String
Untrimmed = ThisWorkbook.Worksheets("data").Range("A" & i).Value
If Len(Trim(Untrimmed) = 0 AND Len(Untrimmed) <> 0 then
Msgbox "a" & i & " contains only space"
End if
Next i
Alternativeley use ThisWorkbook.Worksheets("data").Range("A" & i).Value <> vbNullString to exclude blanks
For i = 1 to lastRow
Dim Untrimmed As String
Untrimmed = ThisWorkbook.Worksheets("data").Range("A" & i).Value
If Len(Trim(Untrimmed) = 0 AND Untrimmed <> vbNullString then
Msgbox "a" & i & " contains only space"
End if
Next i
Just to add alternatives:
With ThisWorkbook.Sheets("data").Range("A" & i)
If .Value Like "?*" And Not .Value Like "*[! ]*" Then
MsgBox ("A" & i & " contains only space")
End If
End With
You may also just create a new regex-object and use pattern ^ +$ to validate the input.
If you don't want to loop the entire range but beforehand would like to exclude the empty cells you could (depending on your data) use xlCellTypeConstants or the numeric equivalent 2 when you decide to use SpecialCells() method and loop the returned cells instead:
Dim rng As Range, cl As Range
Set rng = ThisWorkbook.Worksheets("Data").Range("A:A").SpecialCells(2)
For Each cl In rng
If Not cl.Value Like "*[! ]*" Then
MsgBox ("A" & cl.Row & " contains only spaces")
End If
Next cl
You may also no longer need to find your last used row, but note that this may error out if no data at all is found in column A.
A last option I just thought about is just some concatenation before validation:
For i = 1 To lastRow
If "|" & Trim(ThisWorkbook.Sheets("data").Range("A" & i).value & "|" = "| |" Then
MsgBox ("A" & i & " contains only space")
End If
Next
Macro to get a string of address of cells containing only space using Evaluate VBA function
Edited code below - As suggested by #VBasic2008 and #T.M. in the comments below.
Option Explicit
Sub Cells_with_Space_Only()
Dim ws As Worksheet
Set ws = Sheets("Sheet2")
'Macro to get a string of address of cells containing only space
'https://stackoverflow.com/questions/68891170/finding-cells-with-only-spaces
Dim rngArr, rngStr As String, i As Long, rng As Range
rngArr = Evaluate("IFERROR(ADDRESS((ISBLANK(" & ws.UsedRange.Address(External:=True) & _
")=FALSE)*(" & ws.UsedRange.Address(External:=True) & _
"=REPT("" "",LEN(" & ws.UsedRange.Address(External:=True) & _
")))*ROW(" & ws.UsedRange.Address(External:=True) & _
"),COLUMN(" & ws.UsedRange.Address(External:=True) & ")),""**"")")
rngStr = ""
'If number of columns in usedrange are less then loop with
'For i = 1 To ActiveSheet.UsedRange.Columns.Count
For i = 1 To ws.UsedRange.Rows.Count
'if looped with For i = 1 To ActiveSheet.UsedRange.Columns.Count
'rngStr = Join(Filter(Application.Transpose(Application.Index(rngArr, 0, i)) _
, "**", False, vbBinaryCompare), ",")
rngStr = Join(Filter(Application.Index(rngArr, i, 0) _
, "**", False, vbBinaryCompare), ",")
If rngStr <> "" Then
If rng Is Nothing Then
Set rng = Range(rngStr)
Else
Set rng = Union(rng, Range(rngStr))
End If
End If
Next i
Debug.Print rng.Address
End Sub
The macro returns a string for the sample data in the image below --
$D$1,$A$2,$F$2,$B$3,$E$4,$A$6,$F$6,$E$7,$B$8,$D$9,$C$10,$F$10,$A$11,$D$13,$F$13,$E$14,$A$16,$E$16,$D$17,$F$17:$F$18
Array formula in the worksheet -
=IFERROR(ADDRESS((ISBLANK($A$1:$F$18)=FALSE)*($A$1:$F$18=REPT(" ",LEN($A$1:$F$18)))*ROW($A$1:$F$18),COLUMN($A$1:$F$18)),"**")
Clear Solo Spaces
Couldn't think of any reason for doing this other than for clearing the cells containing only spaces.
Option Explicit
Sub ClearSoloSpaces()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Data")
Dim srg As Range ' Source Range
Set srg = ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim crg As Range ' Clear Range
Dim cCell As Range ' Current Cell in Source Range
Dim cString As String ' Current Cell's Value Converted to a String
For Each cCell In srg.Cells
cString = CStr(cCell.Value)
If Len(cString) > 0 Then
If Len(Trim(cString)) = 0 Then
If crg Is Nothing Then
Set crg = cCell
Else
Set crg = Union(crg, cCell)
End If
End If
End If
Next cCell
If crg Is Nothing Then
MsgBox "No cells containing only spaces found.", _
vbInformation, "Clear Solo Spaces"
Else
Dim Msg As Long
Msg = MsgBox("The cells in the rows '" _
& Replace(crg.Address, "$A$", "") _
& "' of column 'A' contain only spaces." & vbLf _
& "Do you want to clear them?", _
vbInformation + vbYesNo, "Clear Solo Spaces")
If Msg = vbYes Then
crg.Clear ' or crg.ClearContents ' to preserve formatting
End If
End If
End Sub
Just for the sake of showing alternatives (#T.M.), please test the next one, too:
Private Sub testFindSpacesBis()
Dim wsD As Worksheet, i As Long, x As String, lastRow As Long
Set wsD = ActiveSheet ' ThisWorkbook.Sheets("data")
lastRow = wsD.Range("A" & wsD.rows.count).End(xlUp).row
For i = 1 To lastRow
x = wsD.Range("a" & i).Value
If StrComp(x, space(Len(x)), vbBinaryCompare) = 0 Then
MsgBox "a" & i & " contains only spaces"
End If
Next i
End Sub
For each value in Sheet("Scrap2") Column A.
find all matching instances of this value in column A of Sheet("VA_Data"). copy entire row and paste to first empty Row on sheet("List")
My code right now basically only copys the first instance it comes to of the match and then moves to the next value in Sheet("Scrap2").
If there are 10 cells in col A of sheet "VA_Data" that match the first value of Scrap2, then those 10 rows need to copy entire row and paste to first empty rows on sheet "List".
any help is appreciated.
Option Explicit
Public Sub Loop_VA_Data()
Dim wsa As Worksheet
Dim wsb As Worksheet
Dim wsc As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim stra As String
Dim rng As Range
On Error GoTo errLoop_VA_Data
Application.ScreenUpdating = False
Set wsa = ThisWorkbook.Worksheets("Scrap2")
Set wsb = ThisWorkbook.Worksheets("VA_Data")
Set wsc = ThisWorkbook.Worksheets("List")
wsa.Range("B:B").Clear
wsc.Rows("2:" & wsc.Range("A1").CurrentRegion.Rows.Count + 1).Clear
a = 2
Do
If Trim(wsa.Cells(a, 1).Value) = "" Then
Exit Do
End If
stra = Trim(wsa.Cells(a, 1).Value)
Set rng = wsb.Range("A:A").Find(What:=stra, LookIn:=xlValues, LookAt:=xlWhole)
If Not (rng Is Nothing) Then
b = rng.Row
c = wsc.Range("A1").CurrentRegion.Rows.Count + 1
wsb.Rows(b).Copy wsc.Rows(c)
wsa.Cells(a, 2).Value = "Found on row " & b
Else
wsa.Cells(a, 2).Value = "Not Found"
End If
If Not (rng Is Nothing) Then
Set rng = Nothing
End If
a = a + 1
Loop
MsgBox "Complete!", vbInformation
GoTo closeout
Exit Sub
errLoop_VA_Data:
MsgBox "Err Number is: " & Err.Number & " / Err Desc is: " & Err.Description & " in sub Loop_VA_Data!", vbCritical
closeout:
If Not (wsa Is Nothing) Then
Set wsa = Nothing
End If
If Not (wsb Is Nothing) Then
Set wsb = Nothing
End If
If Not (wsc Is Nothing) Then
Set wsc = Nothing
End If
If Not (rng Is Nothing) Then
Set rng = Nothing
End If
Exit Sub
End Sub
I think #urdearboy has the right idea - using a filter & copying en masse. The following code assumes the data on your VA_Data sheet is contiguous. Let me know how you go with it.
Option Explicit
Sub Filter_Copy()
Application.ScreenUpdating = False
Dim c As Range
Dim LastRow As Long, PasteRow As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Sheets("Scrap2")
Set ws2 = Sheets("VA_Data")
Set ws3 = Sheets("List")
LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
For Each c In ws1.Range(ws1.Cells(1, 1), ws1.Cells(LastRow, 1))
With ws2.Cells(1, 1).CurrentRegion
.AutoFilter 1, c.Value
PasteRow = ws3.Cells(Rows.Count, 1).End(xlUp).Row + 1
.Offset(1).Resize(.Rows.Count - 1).Copy ws3.Range("A" & PasteRow)
.AutoFilter
End With
Next c
End Sub
I'm new to macros and VBA in Excel. Is there a way to check if the Testvalue is between Value 1 and Value 2, and move to the corresponding sheet? And if it's not, move to the next row and repeat.
E.g.
With the testvalue 3742 sheet A21 should be selected.
Simply iterate over each row until required condition is met:
Dim testVal As Long, r As Integer
Dim yourSheet As Worksheet
Set yourSheet = Sheet1
With yourSheet
testVal = .Range("E2").Value
r = 2
Do Until (.Range("A" & r).Value <= testVal) And _
(.Range("B" & r).Value >= testVal)
ThisWorkbook.Worksheets(.Range("C" & r).Value).Activate
r = r + 1
Loop
End With
In my opinion, instead of looping each row is faster if you use Find method.
Sub test()
Dim rngSearchA As Range, rngSearchB As Range, rngFoundA As Range, rngFoundB As Range
Dim strValue As String, strSheetName As String
Dim LastRowA As Long, LastRowB As Long
With ThisWorkbook.Worksheets("Sheet1")
strValue = .Range("E2").Value
strSheetName = ""
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
LastRowB = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rngSearchA = .Range("A2:A" & LastRowA)
Set rngSearchB = .Range("B2:B" & LastRowB)
Set rngFoundA = rngSearchA.Find(strValue, LookIn:=xlValues, Lookat:=xlWhole)
Set rngFoundB = rngSearchB.Find(strValue, LookIn:=xlValues, Lookat:=xlWhole)
If Not rngFoundA Is Nothing And Not rngFoundB Is Nothing Then
If .Range("C" & rngFoundA.Row).Value <> .Range("C" & rngFoundB.Row).Value Then
MsgBox "Searching value appears in both columns with different Sheet name."
Else
strSheetName = .Range("C" & rngFoundA.Row).Value
End If
ElseIf Not rngFoundA Is Nothing Or Not rngFoundB Is Nothing Then
If Not rngFoundA Is Nothing Then
strSheetName = .Range("C" & rngFoundA.Row).Value
Else
strSheetName = .Range("C" & rngFoundB.Row).Value
End If
Else
MsgBox "Value not found!"
End If
If strSheetName <> "" Then
ThisWorkbook.Worksheets(strSheetName).Activate
End If
End With
End Sub
I have a spreadsheet with 20+ worksheets listing servers. I am trying to format each sheet to pull only the first four columns of data, while preserving the original data. I am inserting 6 columns on the left, creating column headings, copying the first four rows of data (with starting name of "SERV-"), then putting the name of the worksheet in the 5th column. I got the code to work fine if ran in one sheet. I am trying to put it in a loop, but it isn't working. It is inserting the columns and headers in the first worksheet only.
Once I have this loop working, I want to create a summary tab where it pulls the data from these first five rows of each sheet into the summary tab. This should be easy, but I haven't gotten to that point in the code yet.
This is the code I have so far:
'PhaseOne of test code
Sub PhaseOne()
Dim ws As Worksheet
Dim lngRow As Long
Dim lngCount As Long
lngRow = 8
For Each ws In Worksheets
'(2) Remove blank rows (WORKS)
Dim x As Long
With ws
For x = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
If WorksheetFunction.CountA(.Rows(x)) = 0 Then
ws.Rows(x).Delete
End If
Next
End With
'(3) Insert 5 columns (WORKS)
Columns("A:F").Insert Shift:=xlToRight
'(4) Label columns (WORKS)
Range("$A$1").Value = "ServLabel"
Range("$B$1").Value = "Primary IP"
Range("$C$1").Value = "DC"
Range("$D$1").Value = "Service ID"
Range("$E$1").Value = "Sheet"
'(5) Find and Copy Range (WORKS)
Dim lastRow As Long
With ws
lastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
End With
Dim rFound As Range
On Error Resume Next
Set rFound = Cells.Find(What:="SERV-", _
After:=Cells(Rows.Count, Columns.Count), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If rFound Is Nothing Then
Else
rFound.Select
Selection.Resize(lastRow, numcolumns + 4).Select
Selection.Copy
Range("A2").Select
ws.Paste
End If
'(8) Enter active sheet name in Column E (WORKS)
If ws.Range("A2") = "" Then
Else
Dim lastRow2 As Long
With ws
lastRow2 = .Cells(.Rows.Count, "d").End(xlUp).Row
End With
Range("E2").Select
Selection.Resize(lastRow2 - 1).Select
Selection = ws.Name
End If
Next ws
End Sub
Unless you have some other reason it's probably easier to just scan the sheets and copy the data to the summary.
Option Explicit
Sub summary()
Const SUM_SHEET = "Summary" ' name of smmary sheet
Const PREFIX = "SERV-*"
Dim wb As Workbook, ws As Worksheet, wsSum As Worksheet
Dim iRow As Long, iSumRow As Long
Dim iStartrow As Long, iLastRow As Long, rng As Range, cell As Range
Set wb = ActiveWorkbook
Set wsSum = wb.Sheets(SUM_SHEET)
wsSum.Range("A1:E1") = Array("ServLabel", "Primary IP", "DC", "Service ID", "Sheet")
iSumRow = 1
For Each ws In wb.Sheets
If ws.Name <> SUM_SHEET Then
' find column SERV-
On Error Resume Next
Set rng = ws.Cells.Find(PREFIX)
On Error GoTo 0
' set scan start/end row
If rng Is Nothing Then
MsgBox "Can't find " & PREFIX & " on " & ws.Name, vbCritical
GoTo SkipSheet
Else
iLastRow = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row
iStartrow = rng.Row + 1
End If
Debug.Print ws.Name, "Col=", rng.Column, "iStartRow=", iStartrow, "iLastRow=", iLastRow
' scan the sheet and write to summary
For iRow = iStartrow To iLastRow
Set cell = ws.Cells(iRow, rng.Column)
' skip blank line
If Len(cell) > 0 Then
iSumRow = iSumRow + 1
cell.Resize(1, 4).Copy wsSum.Cells(iSumRow, 1)
wsSum.Cells(iSumRow, 5) = ws.Name
End If
Next
End If
SkipSheet:
Next
MsgBox iSumRow - 1 & " rows copied to " & wsSum.Name, vbInformation
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