Sub SplitWords()
Dim TextStrng As String
Dim Result() As String
Sheets("CO REPORT").Select
TextStrng = Range("K6").Value
Result() = Split(TextStrng)
For i = LBound(Result()) To UBound(Result())
Sheets("RSVP SCOPE").Select
'ActiveSheet.ShowAllData
ActiveSheet.Range("$A$1:$G$791").AutoFilter Field:=1, Criteria1:="=*" &
Result(i) & "*", Operator:=xlOr
MsgBox Result(i)
Worksheets("RSVP SCOPE").Range("1:1").EntireRow.Hidden = True
Set Report = Excel.ActiveSheet
Dim visRng As Range
Set visRng = Report.UsedRange.SpecialCells(xlCellTypeVisible)
Dim r As Range
Dim j As Integer
For Each r In visRng.Rows
j = r.row
MsgBox (j)
Worksheets("RSVP SCOPE").Range("1:1").EntireRow.Hidden = False
ActiveSheet.Range("$A$1:$G$791").AutoFilter.ShowAllData
Next
Next i
End Sub
For the above code, the split words is being used since there will be multiple words in a single cell. I need to copy a text from sheet1 and search that value in column 1 of sheet2 . Now after filtering I need to display the row number for every selected words. In the above code, the first iteration gets executed successfully. But for the second iteration I get a
Your question is broken. I see trouble:
...
' Dim r As Range
Dim r As Variant
...
Related
I'm trying to use the split() function to loop through a specified range and split all strings when a ":" is encountered, and replace the existing value with the split value.
Dim k As Integer
Dim lRow as Long
Dim startZip_col As Long
Dim startZip_str As String
Dim startZip_result() As String
Dim startZip_decomposed As Variant
For k = 2 To lRow
startZip_str = Cells(k, startZip_col).Value
startZip_result = Split(startZip_str, ":")
For Each startZip_decomposed In startZip_result
Cells(k, startZip_col) = startZip_result(1)
Next
Next k
a example of the values i want to split are:
abc:1234
abc:5678
def:3456
tried debug.print to pinpoint where the errors are, but column value is correctly identified, loop looks fine, not sure where went wrong
Logic:
Where is lRow. startZip_col inititalized? Define and initialize your variables/Objects correctly.
Fully qualify the cells else it may refer to active sheet which may not be the sheet you think it is. For example ws.Cells(k, startZip_col).Value where ws is the relevant worksheet.
Before splitting, check for the existence of :
Code:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim i As Long, j As Long
Dim ZipCol As Long
Dim ZipString As String
Dim ZipResult As Variant
'~~> Change this to the relevant sheet
Set ws = Sheet1
'~~> Change this to the releavant column
ZipCol = 1
With ws
'~~> Get the last row in Col A. Change to relevant column
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
ZipString = .Cells(i, ZipCol).Value
'~~> Check if the string contains ":"
If InStr(1, ZipString, ":") Then
ZipResult = Split(ZipString, ":")
'.Cells(1, ZipCol) = ZipResult(1)
'~~> For testing
For j = LBound(ZipResult) To UBound(ZipResult)
Debug.Print ZipResult(j)
Next j
End If
Next i
End With
End Sub
I have code that would compare each cell in column A to everything in column B and do this for the number of lines specified.
This was fine when I had a couple hundred lines, but now I am finding with 2000 lines the code is just not going to cut it. Can anyone look at my code and tell me if there are some improvements to be made or if I should scrap it and do it differently.
Sub highlight()
Dim compare As String
Dim i As Integer
Dim comprange As Range
Dim lines As Integer
i = 2
ScreenUpdating = False
Range("a2").Select
lines = Application.InputBox(Prompt:="How many lines need to be compared?",
_
Title:="SPECIFY RANGE", Type:=1)
Do Until IsEmpty(ActiveCell)
If i + 1 > lines Then
Exit Do
End If
Set comprange = Range("A" & i)
comprange.Select
compare = comprange.Value
i = i + 1
Range("B2").Select
Do Until IsEmpty(ActiveCell.Offset(1, 0))
If ActiveCell.Value = compare Then
ActiveCell.Interior.ColorIndex = 37
ActiveCell.Offset(1, 0).Select
Exit Do
Else
If IsEmpty(ActiveCell.Offset(1, 0)) Then
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
End If
Loop
Loop
compare = ActiveCell.Value
Set comprange = Selection
Range("a2").Select
Do Until IsEmpty(ActiveCell.Offset(1, 0))
If ActiveCell.Value = compare Then
comprange.Interior.ColorIndex = 37
ActiveCell.Offset(1, 0).Select
Exit Do
Else
If IsEmpty(ActiveCell.Offset(1, 0)) Then
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
End If
Loop
End Sub
Try this, it will check ALL your values in column A and if it matches in column B hightlights.
Sub ok()
Dim i, i2 As Long
Dim LastRow, LastRow2 As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With ActiveSheet
LastRow2 = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
For i = 1 To LastRow
For i2 = 1 To LastRow2
If Range("A" & i).Value = Range("B" & i2).Value Then
Range("A" & i).Interior.ColorIndex = 37
Range("B" & i2).Interior.ColorIndex = 37
End If
Next
Next
End Sub
Probably the most efficient way to do this is to use the VBA Dictionary object. There's a great article at https://www.experts-exchange.com/articles/3391/Using-the-Dictionary-Class-in-VBA.html that covers a lot of what you need to know.
Below is a function called DuplicatesBetweenLists that will highlight duplicates between any number of different ranges. When calling it, you can specify:
A range to dump a list of duplicates into (pass in an empty range if you don't want a list generated)
Whether or not you want the duplicate items highlighted
A ParamArray (Comma-separated list) of all the ranges you want to check.
So if you wanted to check all three of columns in the image below for entries that occur in each column, and wanted to output a list to cell E1 of any duplicates as well as highlight them in the data, you'd call the function like this:
Sub test()
Dim rOutput As Range
Set rOutput = Range("E1")
DuplicatesBetweenLists rOutput, True, Range("A2:A11"), Range("B2:B11"), Range("C2:C11")
End Sub
...which would give you something like this:
But if you only wanted highlighting and didn't want the identified duplicates output to a range, you'd simply comment out the Set rOutput = Range("E1") line, and pass in an empty range as the first argument.
It is lightning fast compared to a brute force iteration approach: it handled 2 lists containing 2000 items in less than a second (vs 1 minute for the brute force approach). And it handles 2 lists of 200,000 items in just 12 seconds.
And here's the function itself, as well as another function it calls:
Function DuplicatesBetweenLists(rOutput As Range, bHighlight As Boolean, ParamArray Ranges() As Variant)
Dim vRange As Variant
Dim vInput As Variant
Dim dic_A As Object
Dim dic_B As Object
Dim dic_Output As Object
Dim lOutput As Long
Dim lRange As Long
Dim cell As Range
Dim TimeTaken As Date
TimeTaken = Now()
Set dic_A = CreateObject("Scripting.Dictionary")
Set dic_B = CreateObject("Scripting.Dictionary")
Set dic_Output = CreateObject("Scripting.Dictionary")
Set dic_Range = CreateObject("Scripting.Dictionary")
lRange = 1
For Each vRange In Ranges
vInput = vRange
DuplicatesBetweenLists_AddToDictionary vInput, lRange, dic_A, dic_B
Next vRange
If lRange Mod 2 = 1 Then
Set dic_Output = dic_B
Else: Set dic_Output = dic_A
End If
'Write any duplicate items back to the worksheet
If Not rOutput Is Nothing Then
If dic_Output.Count > 0 Then
If dic_Output.Count < 65537 Then
rOutput.Resize(dic_Output.Count) = Application.Transpose(dic_Output.Items)
Else
'The dictionary is too big to transfer to the workheet
'because Application.Transfer can't handle more than 65536 items.
'So well transfer it to an appropriately oriented variant array,
' then transfer that array to the worksheet WITHOUT application.transpose
ReDim varOutput(1 To dic_Output.Count, 1 To 1)
For Each vItem In dic_Output
lOutput = lOutput + 1
varOutput(lOutput, 1) = vItem
Next vItem
rOutput.Resize(dic_Output.Count) = varOutput
End If
End If
End If
'Highlight any duplicates
If bHighlight Then
'Highlight cells in the range that qualify
Application.ScreenUpdating = False
For Each vRange In Ranges
'Set rInput = vRange
vRange.Interior.ColorIndex = 0
For Each cell In vRange
With cell
If dic_Output.Exists(.Value2) Then .Interior.Color = 65535
End With
Next cell
Next vRange
Application.ScreenUpdating = True
TimeTaken = TimeTaken - Now()
Debug.Print Format(TimeTaken, "HH:MM:SS") & "(HH:MM:SS)"
End If
'Cleanup
Set dic_A = Nothing
Set dic_B = Nothing
Set dic_Output = Nothing
End Function
Private Function DuplicatesBetweenLists_AddToDictionary(varItems As Variant, ByRef lngRange As Long, ByVal dic_A As Object, ByVal dic_B As Object)
Dim lng As Long
Dim dic_dedup As Object
Dim varItem As Variant
Dim lPass As Long
Set dic_dedup = CreateObject("Scripting.Dictionary")
For lPass = 1 To UBound(varItems, 2)
If lngRange = 1 Then
'First Pass: Just add the items to dic_A
For lng = 1 To UBound(varItems)
If Not dic_A.Exists(varItems(lng, 1)) Then dic_A.Add varItems(lng, 1), varItems(lng, 1)
Next
Else:
' Add items from current pass to dic_Dedup so we can get rid of any duplicates within the column.
' Without this step, the code further below would think that intra-column duplicates were in fact
' duplicates ACROSS the columns processed to date
For lng = 1 To UBound(varItems)
If Not dic_dedup.Exists(varItems(lng, lPass)) Then dic_dedup.Add varItems(lng, lPass), varItems(lng, lPass)
Next
'Find out which Dictionary currently contains our identified duplicate.
' This changes with each pass.
' * On the first pass, we add the first list to dic_A
' * On the 2nd pass, we attempt to add each new item to dic_A.
' If an item already exists in dic_A then we know it's a duplicate
' between lists, and so we add it to dic_B.
' When we've processed that list, we clear dic_A
' * On the 3rd pass, we attempt to add each new item to dic_B,
' to see if it matches any of the duplicates already identified.
' If an item already exists in dic_B then we know it's a duplicate
' across all the lists we've processed to date, and so we add it to dic_A.
' When we've processed that list, we clear dic_B
' * We keep on doing this until the user presses CANCEL.
If lngRange Mod 2 = 0 Then
'dic_A currently contains any duplicate items we've found in our passes to date
'Test if item appears in dic_A, and IF SO then add it to dic_B
For Each varItem In dic_dedup
If dic_A.Exists(varItem) Then
If Not dic_B.Exists(varItem) Then dic_B.Add varItem, varItem
End If
Next
dic_A.RemoveAll
dic_dedup.RemoveAll
Else 'dic_B currently contains any duplicate items we've found in our passes to date
'Test if item appear in dic_B, and IF SO then add it to dic_A
For Each varItem In dic_dedup
If dic_B.Exists(varItem) Then
If Not dic_A.Exists(varItem) Then dic_A.Add varItem, varItem
End If
Next
dic_B.RemoveAll
dic_dedup.RemoveAll
End If
End If
lngRange = lngRange + 1
Next
End Function
I have a workbook with 10 sheets. Each sheet has about 30,000 rows with URL. I have a hand full of URLs (about 10 different URLs) that I need to keep the data. Is there a way to delete all the rows from all the worksheet if the first column (Column A - URL) does not contain one of the URL.
for example, I would like to keep we.abc.us, ss.boli.us and 3m.mark.us and delete rest of the rows from all the worksheet in the workbook.
Sub delete0rows()
Dim Worksheet As Excel.Worksheet
Dim lastRow As Long
Dim i As Integer
For Each Worksheet In Application.ThisWorkbook.Worksheets
lastRow = Worksheet.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
Do While i <= lastRow
If Worksheet.Range("A" & i).Value = 0 Then
Worksheet.Rows(i).Delete i = i - 1
lastRow = lastRow - 1
End
i = i + 1
Loop
Next Worksheet
End Sub
I suggest you introduce reverse For loop using Step -1:
Sub delete0rows()
Dim Worksheet As Excel.Worksheet
Dim lastRow As Long
Dim i As Integer
For Each Worksheet In Application.ThisWorkbook.Worksheets
lastRow = Worksheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = lastRow To 1 Step -1
If Worksheet.Range("A" & i).Value = 0 Then
Worksheet.Rows(i).EntireRow.Delete
End If
Next i
Next Worksheet
End Sub
I found this sub a while back. I cannot remember who the original author was or I would credit them. I did tweak it slightly to pass variables into it
The nice thing about this is you can pass multiple deletion criteria by passing a space separated string
Essentially you can give it a row to start at (in case you have headers) tell it the column to look in, the sheet that column is on and your criteria/criterion. So for example if I want it to start at row 5 checking each row below that on a sheet named 'cleanup' checking column 'D' for the words 'cat' 'dog' and 'fish' I would write
Call DelRow(5,"D","cleanup","cat dog fish")
Public Sub DelRow(DataStartRow As Long, SearchColumn As String, SheetName As String, myTextString As String)
' This macro will delete an entire row based on the presence of a predefined word or set of words.
'If that word or set of words is 'found in a cell, in a specified column, the entire row will be 'deleted
'Note the seperator is a space. To change this modify the split parameter
'EXAMPLE CALL: Call DelRow(1, "AH", "Cut Data", "DEL")
Dim X As Long
Dim Z As Long
Dim LastRow As Long
Dim FoundRowToDelete As Boolean
Dim OriginalCalculationMode As Integer
Dim RowsToDelete As Range
Dim SearchItems() As String
SearchItems = Split(myTextString)
On Error GoTo ResetCalcs
OriginalCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
With Worksheets(SheetName)
LastRow = .Cells(.Rows.Count, SearchColumn).End(xlUp).Row
Application.StatusBar = "**** Working on the '" & SheetName & "' Sheet: Number of Rows to be scanned(" & LastRow & "). Deletion keyword " & myTextString & " ***" 'Extra line added
For X = LastRow To DataStartRow Step -1
FoundRowToDelete = False
For Z = 0 To UBound(SearchItems)
If InStr(.Cells(X, SearchColumn).Value, SearchItems(Z)) Then
FoundRowToDelete = True
Exit For
End If
Next
If FoundRowToDelete Then
If RowsToDelete Is Nothing Then
Set RowsToDelete = .Cells(X, SearchColumn)
Else
Set RowsToDelete = Union(RowsToDelete, .Cells(X, SearchColumn))
End If
If RowsToDelete.Areas.Count > 100 Then
RowsToDelete.EntireRow.Delete
Set RowsToDelete = Nothing
End If
End If
Next
End With
If Not RowsToDelete Is Nothing Then
RowsToDelete.EntireRow.Delete
End If
ResetCalcs:
Application.Calculation = OriginalCalculationMode
End Sub
My macro creates a large text file by writing all the data from all sheets in the active workbook.
In each worksheet, it is necessary to determine a certain rectangular range of cells that would be saved in the text file. It's upper left corner would always be A1, but the lower right corner should be chosen so that the range includes all cells with any content (formatting does not matter).
I thought ws.Range("A1").CurrentRegion would do the trick, but it does not work when A1 and the nearby cells are empty. If the only cell with data in the sheet is Q10, then the range should be A1:Q10.
Of course, I could loop over the ws.Cells range to discover the range of interest, but that's quite time consuming, I hope there's more effective way. If I select all cells in a sheet and do a copy-paste to notepad, I do not end up with hundreds of empty columns and thousands of empty rows, only the relevant data are copied. The question is how to replicate that with VBA.
This is my code so far:
Sub CreateTxt()
'This macro copies the contents from all sheets in one text file
'Each sheet contents are prefixed by the sheet name in square brackets
Dim pth As String
Dim fs As Object
Dim rng As Range
pth = ThisWorkbook.Path
Set fs = CreateObject("Scripting.FileSystemObject")
Dim outputFile As Object
Set outputFile = fs.CreateTextFile(pth & "\Output.txt", True)
Dim WS_Count As Integer
Dim ws As Worksheet
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 1 To WS_Count
Set ws = ActiveWorkbook.Worksheets(I)
outputFile.WriteLine ("[" & ws.Name & "]")
Debug.Print ws.Name
Set rng = ws.Range("A1").CurrentRegion
outputFile.WriteLine (GetTextFromRangeText(rng, vbTab, vbCrLf))
Next I
outputFile.Close
End Sub
Function GetTextFromRangeText(ByVal poRange As Range, colSeparator As String, rowSeparator As String) As String
Dim vRange As Variant
Dim sRow As String
Dim sRet As String
Dim I As Integer
Dim j As Integer
If Not poRange Is Nothing Then
vRange = poRange
Debug.Print TypeName(vRange)
For I = LBound(vRange) To UBound(vRange)
sRow = ""
For j = LBound(vRange, 2) To UBound(vRange, 2)
If j > LBound(vRange, 2) Then
sRow = sRow & colSeparator
End If
sRow = sRow & vRange(I, j)
Next j
If sRet <> "" Then
sRet = sRet & rowSeparator
End If
sRet = sRet & sRow
Next I
End If
GetTextFromRangeText = sRet
End Function
if there is anything in A1:B2 cells, this macro works. It breaks when the A1:B2 is empty and the CurrentRegion property returns Empty.
I think you should use these functions to find the last Row/Column
lastRow = Sheets("Sheetname").Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Sheets("Sheetname").Cells(1, Columns.Count).End(xlToLeft).Column
You specify the name of the sheet and the row/columb-number that you want to find the last cell with information, and it return the number of it.
(In the example the last row in first column, and last column in first row are find)
lastCol will give you an Long as an asnwer. If you want to convert this number into the column letter you can use the next function
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
I hope you find this useful
Thanks to user Rosetta, I've come up with this expression for the sought range:
ws.Range("A1:" & ws.Cells.SpecialCells(xlLastCell).Address)
I am working through my first VBA book and would appreciate if someone would point me in the right direction. How would I transfer a range of rows into a single cell with carriage returns? I would then like to repeat this action for all ranges in the column.
I think I need to:
find the first cell with a value in the column
verify that the next row is not empty
find the last cell in the range
perform "the operation" on the range
Following up on my comments. here is a very simple way to achieve what you want.
Option Explicit
'~~> You can use any delimiter that you want
Const Delim = vbNewLine
Sub Sample()
Dim rngInput As Range, rngOutput As Range
Application.ScreenUpdating = False
Set rngInput = Range("A1:A5") '<~~ Input Range
Set rngOutput = Range("B1") '<~~ Output Range
Concatenate rngInput, rngOutput
Application.ScreenUpdating = True
End Sub
Sub Concatenate(rng1 As Range, rng2 As Range)
Dim cl As Range
Dim strOutPut As String
For Each cl In rng1
If strOutPut = "" Then
strOutPut = cl.Value
Else
strOutPut = strOutPut & Delim & cl.Value
End If
Next
rng2.Value = strOutPut
End Sub
Within the context of a worksheet-level code, the following will work. Column 2 is hard-coded, so you might want to pass in a value or otherwise modify it to fit your needs.
Dim rng As Range
Set rng = Me.Columns(2)
Dim row As Integer
row = 1
' Find first row with non-empty cell; bail out if first 100 rows empty
If IsEmpty(Me.Cells(1, 2)) Then
Do
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2)) = False Or row = 101
End If
If row = 101 Then Exit Sub
' We'll need to know the top row of the range later, so hold the value
Dim firstRow As Integer
firstRow = row
' Combine the text from each subsequent row until an empty cell is encountered
Dim result As String
Do
If result <> "" Then result = result & vbNewLine
result = result & Me.Cells(row, 2).Text
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2))
' Clear the content of the range
Set rng = Me.Range(Me.Cells(firstRow, 2), Me.Cells(row, 2))
rng.Clear
' Set the text in the first cell
Me.Cells(firstRow, 2).Value2 = result