I am trying to search a column for cells that contain certain text, and if they do, copy the value next to it and paste in the first free row of an assigned range. Below is the code I am using, it will return the one value but is not looping to return the others.
Const SB As String = "*SB*"
Dim cel As Range
Dim sbcellvalue As Variant
Dim SBpull As Range
Dim SBpaste As Range
Set SBpull = Worksheets("SBImport").Range("Q:Q")
Set SBpaste = Worksheets("Misc").Range("SBRange")
For Each cel In SBpull.Cells
If InStr(1, sbcellvalue, SB, vbTextCompare) > 0 Then
sbcellvalue = cel.Offset(0, 1).Value
SBpaste.Offset(1, 0).End(xlUp) = sbcellvalue
End If
Next cel
MsgBox "search done"
End Sub
Related
I try to get my finances together and for that downloaded my data from the local bank as excel. As it is pretty wild (and some years), I want display the data summed up for what I use my money for, as "food", "rent" and stuff. For that I want to go through all the rows and check if a certain cell in the row contains any known word, where I know where to put it in my expenses.
For example: if there is the name of a restaurant in a certain cell, it is a food expense, but the same if it is walmart for example.
I came up with something like:
Dim food() As String
food(0) = "Nespresso"
food(1) = "Spar"
food(2) = "Billa"
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("I3:I9")
For Each cel In SrchRng
If InStr(1, cel.Value, food(0)) Or InStr(1, cel.Value, food(1)) Or InStr(1, cel.Value, food(2)) > 0 Then
cel.Offset(0, 3).Value = "Essen/Trinken"
Else
cel.Offset(0, 3).Value = "-"
End If
Next cel
But there are some problems with the code:
if all the variables are in a array, there certanly is a way to not be specific and go through array(0), (1), ... but I don't know how.
to make it more "editable" and convenient, I don't want to hardcode it, but have a 2nd sheet which displays "food" in A1 and on A2-n the different variables for food(0)-food(n-2) should be used.
using the range to a fixed amount also is not a good way how to make sure to work on any given data, it would be best to check for the last row with data first
I already found ways to come to answer point 3 tho.
Everything would help.
Thanks in advice :)
I'm not so sure if I understand you correctly. Anyway....
to make it more "editable" and convenient, I don't want to hardcode
it, but have a 2nd sheet which displays "food" in A1 and on A2-n the
different variables for food(0)-food(n-2) should be used.
As seen in the image above, in Sheet2 there is a table for lookup of the expenses - and in Sheet1 column i is the expenses.
The expected result after running the macro is something like below :
Sub test()
Dim rgData As Range: Dim rgExp As Range: Dim rgU As Range
Dim c As Range: Dim cell As Range: Dim fa As String
With Sheets("Sheet1")
Set rgData = .Range("i3:i14") 'change if needed
End With
With Sheets("Sheet2")
Set rgExp = .Range("A1", .Range("A1").End(xlDown)) 'change if needed
End With
For Each cell In rgExp
Set c = rgData.Find(cell.Value, lookat:=xlPart)
If Not c Is Nothing Then
fa = c.Address
Do
If rgU Is Nothing Then Set rgU = c Else Set rgU = Union(rgU, c)
Set c = rgData.FindNext(c)
Loop Until c.Address = fa
rgU.Offset(0, 3).Value = cell.Offset(0, 1).Value
Set rgU = Nothing
End If
Next
End Sub
rgExp is the range of column A in Sheet2.
rgData is the range of column i in Sheet1.
The loop is not within the rgData but rgExp.
Within this loop, it loop with find/find-next method to unite the range of the found cell (which value contains the looped cell value in rgExp) as rgU variable. Then it fill the rgU.offset(0,3) with the looped cell.offset(0,1) value.
If in Sheet2 the table you want is something like this :
Then set the rgExp like this
With Sheets("Sheet2")
Set rgExp = .UsedRange.Offset(1, 0).SpecialCells(xlConstants)
End With
and after the find-next loop done, the filling for the rgU.offset(0,3) is like this :
rgU.Offset(0, 3).Value = rgExp.Find(cell.Value).End(xlUp).Value
This is the perfect time to use a function. You can create a function which loops through multiple search terms, checking each of them and returning the result.
Function FindAny(SearchIn As String, LookFor() As String, Optional Start As Long = 1, Optional Compare As VbCompareMethod = vbTextCompare) As Boolean
'Search for each of the given search terms in the given string, return true if any of them are found.
Dim SearchTerm As Variant
For Each SearchTerm In LookFor
If InStr(Start, SearchIn, SearchTerm, Compare) <> 0 Then
FindAny = True
Exit Function
End If
Next
'Else - Search terms not found
FindAny = False
End Function
Here's how to include that in your original code:
Sub Example()
Dim Food() As String
Food = Split("Nespresso,Spar,Billa", ",")
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("I3:I9")
For Each cel In SrchRng
If FindAny(CStr(cel.Value), Food) Then
cel.Offset(0, 3).Value = "Essen/Trinken"
Else
cel.Offset(0, 3).Value = "-"
End If
Next cel
End Sub
Given that I am told we should be using Centered Across Selection instead of Merged Cells, I need to get the underlying value that is displayed across the cells when formatted as Centered Across Selection.
When using Merged Cells, it was easy:
CellValue = rng.MergeArea.Cells(1, 1).Value
Is there an easy way to get the same for Centered Across Selection, other than searching backwards while HorizontalAlignment = xlHAlignCenterAcrossSelection until the Cell Value <> "". My code to do this would be:
Function GetCenteredAcrossSelectionCellValue(rng As Range) As Variant
Dim i As Long
Dim l As Long
Dim ws As Worksheet
Set ws = rng.Worksheet
i = rng.Column
r = rng.Row
If rng.HorizontalAlignment = xlHAlignCenterAcrossSelection Then
Do Until (ws.Cells(r, i).Value <> "" And rng.HorizontalAlignment = xlHAlignCenterAcrossSelection)
i = i - 1
Loop
End If
GetCenteredAcrossSelectionCellValue = ws.Cells(r, i).Value
End Function
However, I don't this this is foolproof, because it could be possible that someone applied Center Across Selection to a single cell (say A1 for example) with a value, and then applied Center Across Selection to 3 empty cells (B1:D1). When asked for the "value" for D1, the above code would return the value in A1.
Excel must know because it formats correctly, so is there an easy way to tell in VBA, similar to the way we can tell for Merged Cells?
Following on from the comment above...
Apply "center across selection" to A1:J1 then run tester with values in different cells in that range and compare the outputs.
Sub tester()
Dim c As Range, rng As Range
For Each c In Range("A1:J1")
Set rng = CenteredRange(c)
If Not rng Is Nothing Then
Debug.Print c.Address, rng.Address
Else
Debug.Print c.Address, "not centered"
End If
Next c
End Sub
'return the current "center across" range given a starting point
Function CenteredRange(c As Range) As Range
Dim cStart As Range, cEnd As Range, cNext As Range
Set c = c.Cells(1) 'make sure we're dealing with a single cell
If Not c.HorizontalAlignment = xlCenterAcrossSelection Then Exit Function
Set cStart = c.Parent.Range(c.Address)
Set cEnd = c.Parent.Range(c.Address)
'look for the beginning
Do While cStart.Column > 1 And cStart.HorizontalAlignment = xlCenterAcrossSelection
If Len(cStart.Value) > 0 Then Exit Do 'stop if find a value
Set cStart = cStart.Offset(0, -1)
Loop
'look for the end
Do While cEnd.Column < Columns.Count - 1 And cEnd.HorizontalAlignment = xlCenterAcrossSelection
Set cNext = cEnd.Offset(0, 1) 'checking the next cell...
If Len(cNext.Value) > 0 Or cNext.HorizontalAlignment <> xlCenterAcrossSelection Then Exit Do
Set cEnd = cEnd.Offset(0, 1)
Loop
Set CenteredRange = c.Parent.Range(cStart, cEnd)
End Function
I have two ranges as showed in this picture.
I'm trying to write a VBA macro that successively selects a single cell in the first range (“B23, F27”) , copies the selected cell's value, then selects a random cell in the second range (“G23, K27”), and pastes the first cell's value into the randomly selected cell in the second range.
This should repeat until every cell from the first range has been copied, or every cell in the second range is filled with a new value. In this example both outcomes are equivalent as both ranges have the same number of cells (25).
The result should be like the second image.
I tried to assign the first range to an array and then pick a random value from this array and paste it to the second range.
I also tried to extract unique values from the first range, build a dictionary with it then pick a random cell from the second range and a random value from the dictionary and paste it.
Later I tried again using the VBA syntax “with range” and f"or each cell in range" but I can’t just come up with something that actually works. Sometimes the second range is filled by various values, but not as intended.
First example: this one just does not work
Sub fillrange()
Dim empty As Boolean
'This part checks if every cell in the first range as a value in it
For Each Cell In Range("B23", "F27")
If Cell.Value = "" Then
empty = True
End If
Next
'If every cell is filled then
If empty Then
Exit Sub
Else:
With ThisWorkbook.Worksheets("Sheet1)").Range("B23", "F27")
.Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
.Copy 'the cell select works, but it will copy all range
'This does not work
'For Each Cell In Range("G23", "K27")
'Cells(Application.WorksheetFunction.RandBetween(1, 25)).Select
'.PasteSpecial Paste:=xlPasteValues
'Next
End With
End If
End Sub
Second example: it fills the range but with wrong values
Sub fillrange2()
Dim empty As Boolean
For Each cell In Range("B23", "F27")
If cell.Value = "" Then
empty = True
'This part checks if every cell in the first range as a value in it
Exit For
End If
Next cell
If empty Then
Exit Sub
Else:
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection, itm As Variant
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
On Error Resume Next
col.Add .Range("B23", "F27").Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
Dim MyAr() As Variant
ReDim MyAr(0 To (col.Count - 1))
For i = 1 To col.Count
MyAr(i - 1) = col.Item(i)
Next
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End If
End Sub
Third example: as the second example, it fills the range but with wrong values
Sub fillrange3()
Dim MyAr() As Variant
MyAr = Range("B23", "F27")
For Each cell In Range("G23", "K27")
cell.Value = Application.WorksheetFunction.RandBetween(LBound(MyAr), UBound(MyAr))
Next
End Sub
Maybe something like this ?
Sub test()
Set Rng = Range("G23:K27")
n = 1
totCell = 25
Set oFill = Range("G23")
Set oSource = Range("B23")
For i = 1 To 5
oFill.Value = "X" & n
oFill.AutoFill Destination:=Range(oFill, oFill.Offset(4, 0)), Type:=xlFillSeries
Set oFill = oFill.Offset(0, 1)
n = n + 5
Next i
For i = 1 To 5
Do
RndVal = Int((totCell - 1 + 1) * Rnd + 1)
xVal = "X" & RndVal
Set C = Rng.Find(xVal, lookat:=xlWhole)
If Not C Is Nothing Then
C.Value = oSource.Value
Set oSource = oSource.Offset(1, 0)
check = check + 1
If check = 5 Then Exit Do
End If
Loop
Set oSource = oSource.Offset(-5, 1)
check = 0
Next i
End Sub
I cheat by making a preparation for the range G23 to K27 fill with X1 to X25 in the first for i = 1 to 5.
The second for i = 1 to 5 is to offset from column B to G.
The Do - Loop is to generate random number between 1 to 25.
If the generated number is found then the found cell has the value from the "source",
if not found, it loop until the generated number is found 5 times (hence also the found cell is fill with 5 different source). Then before the next i, the "source" cell is offset to the next column.
This if I'm not wrong to get what you mean.
Here's another approach, just for a bit of variety.
Sub x()
Dim r1 As Range, r2 As Range, i As Long
Dim r As Long, c As Long
Set r1 = Range("B23").Resize(5, 5) 'define our two ranges
Set r2 = Range("G23").Resize(5, 5)
r2.ClearContents 'clear output range
With WorksheetFunction
Do Until .Count(r2) = r2.Count 'loop until output range filled
r = .RandBetween(1, 25) 'random output cell number
If .CountIf(r2, r1.Cells(i)) = 0 Then 'if not in output range already
If r2.Cells(r) = vbNullString Then 'if random cell empty
r2.Cells(r).Value = r1.Cells(i).Value 'transfer value
i = i + 1
End If
End If
Loop
End With
End Sub
I'm currently working on the statement that implies, that if any of the cell value in the range of "G3:ED3" in the worksheet named "Matrix", matches the cell value in the range of "H3:H204" in the worksheet named "Staff" and any cell value in the range "G5:ED57" in the "Matrix" worksheet is numeric, then the value of the cell in a column B, that intersects the numeric value, is retrieving to the required cell address in the target template.
Here's what I have tried so far:
Dim rng1 As Range
Set rng1 = Worksheets("Matrix").Range("G3:ED3")
Dim rng2 As Range
Set rng2 = Worksheets("Staff").Range("H3:H204")
Dim rng3 As Range
Set rng3 = Worksheets("Matrix").Range("G5:ED57")
For Each cell In Range(rng1, rng2, rng3)
While IsNumeric(rng3) And rng1.Value = rng2.Value
Worksheets("Matrix").Columns("B").Find(0).Row =
Worksheets("TEMPLATE_TARGET").Value(12, 4)
Wend
I'm unsure how to define the statement, so the code would automatically retrieve the value of the cell in a column B, that intersects any cell that contains numeric value in the rng3. Any recommendations would be highly appreciated.
it's probably best you take a proper look into documentation / whatever learning resource you are using as you seem to have missunderstood how While works (alongside few other things)
While is a loop within itself, it does not act as an Exit Condition for the For loop.
With all that said, it's also unclear from your question what you're trying to achieve.
My presumption is, that you want to check for all the conditions and
then if they do match, you're looking to paste the result into the
"TEMPLATE" sheet
First we create a function th ceck for values in the two data ranges:
Private Function IsInColumn(ByVal value As Variant, ByVal inSheet As String) As Boolean
Dim searchrange As Range
On Error Resume Next ' disables error checking (Subscript out of range if sheet not found)
' the range we search in
If Trim(LCase(inSheet)) = "matrix" Then
Set searchrange = Sheets("Matrix").Range("G5:ED7")
ElseIf Trim(LCase(inSheet)) = "staff" Then
Set searchrange = Sheets("Staff").Range("H3:H204")
Else
MsgBox ("Sheet: " & inSheet & " was not found")
Exit Function
End If
On Error GoTo 0 ' re-enable error checking
Dim result As Range
Set result = searchrange.Find(What:=value, LookIn:=xlValues, LookAt:=xlWhole)
' Find returns the find to a Range called result
If result Is Nothing Then
IsInColumn = False ' if not found is search range, return false
Else
If IsNumeric(result) Then ' check for number
IsInColumn = True ' ding ding ding, match was found
Else
IsInColumn = False ' if it's not a number
End If
End If
End Function
And then we run the procedure for our search.
Private Sub check_in_column()
Dim looprange As Range: Set looprange = Sheets("Matrix").Range("G3:ED3")
Dim last_row As Long
For Each cell In looprange ' loops through all the cells in looprange
'utlizes our created IsInColumn function
If IsInColumn(cell.Value2, "Matrix") = True And _
IsInColumn(cell.Value2, "Staff") = True Then
' finds last actively used row in TEMPLATE_TARGET
last_row = Sheets("TEMPLATE_TARGET").Cells(Rows.Count, "A").End(xlUp).Row
' pastes the found value
Sheets("TEMPLATE_TARGET").Cells(last_row, "A") = cell.Value2
End If
' otherwise go to next cell
Next cell
End Sub
I redefined your ranges a little in my example for utility reasons but it works as expected
In my Matrix sheet: (staff sheet only contains copy of this table)
In my TEMPLATE_TARGET sheet after running the procedure.
Result as expected
If I understand well, I would have done something like this:
Option Explicit
Public Sub Main()
Dim wsMatrix As Worksheet: Set wsMatrix = ThisWorkbook.Worksheets("Matrix")
Dim rgMatrix As Range: Set rgMatrix = wsMatrix.Range("G3:ED3")
Dim cell As Range
Dim cellStaff As Range
Dim cellMatrix As Range
For Each cell In rgMatrix
If CheckRangeStaff(cell.Range) And CheckRangeMatrix() Then
'Process in a column B? Which sheet? Which cell? Which Process?
End If
Next cell
Debug.Print ("End program.")
End Sub
Public Function CheckRangeStaff(ByVal value As String) As Boolean
Dim wsStaff As Worksheet: Set wsStaff = ThisWorkbook.Worksheets("Staff")
Dim rgStaff As Range: Set rgStaff = wsStaff.Range("H3:H204")
Dim res As Boolean
Dim cell As Range
res = False
For Each cell In rgStaff
If cell.value = value Then
res = True
Exit For
End If
Next cell
CheckRangeStaff = res
End Function
Public Function CheckRangeMatrix() As Boolean
Dim wsMatrix As Worksheet: Set wsMatrix = ThisWorkbook.Worksheets("Matrix")
Dim rgMatrix As Range: Set rgMatrix = wsMatrix.Range("G5:ED57")
Dim res As Boolean
Dim cell As Range
res = False
For Each cell In rgMatrix
If IsNumeric(cell.value) Then
res = True
Exit For
End If
Next cell
CheckRangeMatrix = res
End Function
In my Excel sheet, I have VBA code to detect the last non-empty cell in Column A and add incremental serial number value in that cell (in below example cell A6 value should be SN104).
This processing is limited only to Column A, and in this image example first non-empty last cell is at A6, sometimes it can be after 100 cells or 1000 cells.
Is there any simple way to handle this scenario?
Public Function GetLastCell(ByVal startRng as Range) as Range
With startRng
Set GetLastCell = IIf(.Offset(1).Value = "", .Offset(0), .End(xlDown))
End With
End Function
For your example, you can define a Range variable rng, and call the above function in this way:
Dim rng as Range
Set rng = GetLastCell( Range("A1") )
Then rng is referring to the last cell of Column A
Something like
Dim lngLastUsedRow as Integer
lngLastUsedRow = Range("A65536").End(xlUp).Row
Dim lngFirstEmptyRow as Integer
lngFirstEmptyRow = Range("A65536").End(xlUp).Offset(1,0)
// do your increment
newValue = Cint(Mid(CurrentWorkSheet.Range("A" + lngLastUsedRow).Value,2)) + 1
CurrentWorkSheet.Range("A" & lngFirstEmptyRow).Value = "SN" + newValue
I don't have excel on me, I can't test it right now. But this should get you started.
Something like this which
Find the true last used cell in any Excel version, and handles a blank result
Parses the string in the last non-blank cell (handling any length of alpha then numeric)to update the next blank cell
Sub GetTrueLastCell()
Dim rng1 As Range
Dim objRegex As Object
Dim strFirst As String
Set rng1 = Columns("A").Find("*", [a1], xlFormulas)
If Not rng1 Is Nothing Then
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "^(.+?[^\d])(\d+)$"
If .test(rng1.Value) Then
strFirst = .Replace(rng1.Value, "$1")
rng1.Value = strFirst & (Val(Right$(rng1.Value, Len(rng1.Value) - Len(strFirst)) + 1))
End If
End With
Else
MsgBox "Data range is blank"
End If
End Sub
Assumptions:
Next cell in list is empty
Serial N's only have three digits after 'SN' string (i.e., if it reaches 1000, earlier ones don't need padding, like '0100'
-
Dim rAll As Range, rLast As Range, rNext As Range, iNextSN As Integer
Set rAll = Intersect(Sheet1.Cells(1).CurrentRegion, Sheet1.Columns(1)) ' Column 'A' can be contiguous with others
Set rLast = rAll.Cells(rAll.Cells.Count) ' Last cell in current list
Set rNext = rLast.Offset(1) ' Next cell below current list
iNextSN = CInt(Right(rLast.Value, 3)) ' Get value of last serial N
rNext.Value = "SN" & iNextSN + 1 ' Assemble next SN with increment
-