I would need some help on the following excel 2010 vba:
I would like to select all cells which contain a specific number format. The cells can be located anywhere in column A.
Any ideas are welcome.
Thank you in advance!
This code:
Dim Tmp As String
Tmp = ""
For Each xx In Range("A1:A1000")
If (xx.NumberFormat = "0") Then
Tmp = Tmp & "," & xx.Address
End If
Next
Tmp = Mid(Tmp, 2)
Range(Tmp).Select
select all the cells that have NumberFormat "0" ... Substitute the if stantement in base of your request.
Here is a way using the Range.Find method
Option Explicit
Sub CellsWithNumberFormat()
Dim R As Range, C As Range
Const sFmt As String = "0.00" '<-- set to whatever numberformat you want
Dim colAddr As Collection
Dim sFirstAddress As String
Dim I As Long
Dim sTemp As String
Set R = Cells.Columns(1)
With Application.FindFormat
.NumberFormat = sFmt
End With
Set colAddr = New Collection
With R
Set C = .Find(what:="", LookIn:=xlValues, searchformat:=True)
If Not C Is Nothing Then
colAddr.Add Item:=C.Address
sFirstAddress = C.Address
Do
Set C = .Find(what:="", after:=C, searchformat:=True)
If C.Address <> sFirstAddress Then
colAddr.Add Item:=C.Address
End If
Loop Until sFirstAddress = C.Address
End If
End With
For I = 1 To colAddr.Count
sTemp = sTemp & "," & colAddr(I)
Next I
sTemp = Mid(sTemp, 2)
Range(sTemp).Select
End Sub
Related
I have a file called tg. I'd like to loop through the column A and everytime I come across an uppercase bold value, I'd like to store it as a key of my dictionary pp. The item associated is a collection of all the values up until the next uppercase and bold value. And repeat. My code doesn't seem to produce anything. Any help would be appreciated.
EDIT: I tested the my code with:
MsgBox (Pairs.Items(0).Count) and I get 0.
Function Pairs() As Dictionary
Call Files
With tg
Dim rng As Range
Dim pp As New Dictionary
Dim item As Variant
Dim arr
Dim gp As Variant
Set arr = New Collection
For Each rng In .Range("A1:A50")
If Not IsEmpty(rng) And IsUpper(rng.Value) And rng.Value <> "NULL" And rng.Font.Bold = True Then
gp = rng.Value
Do While Not IsEmpty(rng) And Not IsUpper(rng.Value) And rng.Font.Bold = True '
arr.Add rng.Value
Loop
pp.Add gp, arr
End If
Next rng
Set Pairs = pp
End With
End Function
Please, use the next faster way. It find the first Bolded cell, checks if isUpper and place in a dictionary (as key) the matched such cells value and the range in between as item:
Function Pairs() As Scripting.Dictionary
Dim tg As Worksheet, rng As Range, cB As Range, firstAddress As String, pp As New Scripting.Dictionary
Set tg = ActiveSheet 'use here the sheet you need
Set rng = tg.Range("A1:A50")
With Application.FindFormat
.Clear
.Font.Bold = True
End With
Set cB = rng.Find(what:=vbNullString, Searchformat:=True)
Dim prevRow As Long, prevKey As String
If Not cB Is Nothing Then
If IsUpper(cB.value) Then
firstAddress = cB.Address:
Do
If prevRow <> 0 Then Set pp(prevKey) = tg.Range("A" & prevRow & ":A" & cB.row - 1)
pp.Add cB.value, 1: prevRow = cB.row: prevKey = cB.value
Do
Set cB = rng.Find(what:=vbNullString, After:=cB, Searchformat:=True)
Loop Until IsUpper(cB.value)
Loop While cB.Address <> firstAddress
End If
Set pp(prevKey) = tg.Range("A" & prevRow & ":A50")
Else
MsgBox "No bolded cell in Uppercase has been found..."
End If
Set Pairs = pp
End Function
Function IsUpper(s) As Boolean
With CreateObject("VBScript.RegExp")
.Pattern = "^[^a-z]*$"
IsUpper = .test(s)
End With
End Function
It can be tested with something like:
Sub testPairs()
Dim i As Long, pp As Scripting.Dictionary
Set pp = Pairs
If pp.count = 0 Then Exit Sub
For i = 0 To pp.count - 1
Debug.Print pp.Keys()(i), pp.Items()(i).Address
Debug.Print Join(Application.Transpose(pp.Items()(i).value), "|")
Next i
End Sub
For the last occurrence it uses the range starting below it and the last cell in the range. If you will not use something static ("A1:A50"), the calculated last cell can be used...
If you need/want a collection instead of range as a dictionary item, it can be done, but in the way I tried handling the processing the range looks the most appropriate. You can easily place the range in an array and do whatever you need with it...
Please, send some feedback after testing it.
Your loop starting with Do While Not IsEmpty(rng) needs an incrementation, otherwise will exit immediately in case of a match but will stay in a continuous loop if not...
If you like more your way, or want better understanding where the mistake is, please replace this part:
Do While Not IsEmpty(rng) And Not IsUpper(rng.Value) And rng.Font.Bold = True '
arr.Add rng.Value
Loop
Firstly a new variable should be declared `Dim i As Long`.
Then replace with:
Do
arr.Add rng.Offset(i).value
i = i + 1
Loop Until IsUpper(rng.Offset(i).value) And rng.Offset(i).Font.Bold = True Or rng.Offset(i).value = ""
i = 0
Do is not oK use If, and a problem in For.
For Each rng In .Range("A1:A50").Cells
I have been using the below code to run a vlookup-style search and return all matches (whilst omitting duplicates and blanks). I want to convert this into a VBA macro that I can call using a button to, by row, search for the value in column C in column A, and return each corresponding value from column B. I want these results printed in column D, separated by a ";". Does anyone know a good way to do this? I've also attached an example image of my goal output.
Thanks!
Public Function Vlookup2(ByVal Lookup_Value As String, ByVal Cell_Range As
Range, ByVal Column_Index As Integer) As Variant
Dim cell As Range
Dim Result_String As String
On Error GoTo eHandle
For Each cell In Cell_Range
If cell.Value = Lookup_Value Then
If cell.Offset(0, Column_Index - 1).Value <> "" Then
If Not Result_String Like "*" & cell.Offset(0, Column_Index - 1).Value & "*" Then
Result_String = Result_String & ";!;" & cell.Offset(0, Column_Index - 1).Value
End If
End If
End If
Next cell
Vlookup2 = LTrim(Right(Result_String, Len(Result_String) - 1))
Exit Function
eHandle:
Vlookup2 = ""
End Function
Here's one approach you could try:
Sub SummarizeAddresses()
Dim dict As Object, c As Range, ws As Worksheet
Dim pc As String, addr As String, k
Set dict = CreateObject("scripting.dictionary")
Set ws = ActiveSheet 'or whatever
'loop over the input data
For Each c In ws.Range("A2:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row).Cells
pc = Trim(c.Value)
addr = c.Offset(0, 1).Value
If Not dict.exists(pc) Then Set dict(pc) = New Collection 'new code?
On Error Resume Next 'ignore error if adding a duplicate
dict(pc).Add addr, addr
On Error GoTo 0 'stop ignoring errors
Next c
Set c = ws.Range("C2") 'starting point for output
For Each k In dict
c.Value = k
c.Offset(0, 1).Value = CollectionItems(dict(k))
Set c = c.Offset(1, 0) 'next row down
Next k
End Sub
'return a string with all elements of a collection
Function CollectionItems(col As Collection)
Dim rv As String, e, sep As String
For Each e In col
rv = rv & sep & e
sep = ";"
Next e
CollectionItems = rv
End Function
I'm needing to find the first row numbers of cell in column C that contains "120" without duplicates (data I have has more than 10 of each number code, I only need the first one). So the code should pick up the first row number containing e.g. 120, 7120, 81200.
The code I've tried below have only managed to find the first row number with cell that contained 120. For reference, AGCL is a column letter derived from another find function and tbAC is a user input into a textbox.
Dim AGCN As Long
Dim AGCL As String
Dim AGNN As Long
Dim AGNL As String
Dim i As Long
Dim RowD As Long
Dim AAC As String
Dim rng As Range
Dim rownumber As Long
Dim AGC As Range
Dim AGN As Range
Dim firstaddress As Long
Dim nextaddress As Long
Set rng = Sheet1.Columns(AGCL & ":" & AGCL).Find(what:="*" & tbAC & "*",
LookIn:=xlValues, lookat:=xlPart)
rownumber = rng.Row
Debug.Print rownumber '9
With Sheet1.Range(AGCL & ":" & AGCL)
Set c = .Find("*" & tbAC & "*", LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Value
Debug.Print firstaddress
With Me.ListBox2
.ColumnCount = 3
.ColumnWidths = "50;150;70"
.AddItem
.List(i, 0) = Str(firstaddress)
i = o + 1
End With
Do
Set c = .FindNext(c)
If c Is Nothing Then
GoTo donefinding
ElseIf firstaddress <> c.Value Then
nextaddress = c.Value
Debug.Print nextaddress 'it doesn't print any value here
'With Me.ListBox2
' .ColumnCount = 3
' .ColumnWidths = "50;150;70"
' .AddItem
' .List(i, 0) = Str(nextaddress)
' Debug.Print nextaddress
' i = o + 1
'End With
End If
Loop While c.Address <> firstaddress
End If
donefinding: Exit Sub
End With
Any help would be greatly appreciated, thank you!
Here is the Range.FindNext Function you can use to retrieve all the cells having 120.
With Sheet1.Range(AGCL & ":" & AGCL)
Set c = .Find("*" & tbAC & "*", lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
If c is Nothing Then
GoTo DoneFinding
Elseif not firstaddress.value = c.value
''Whatever you want to do with the Second Found Value
debug.print c.value
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
Now to check that the value already found or not, you can play in the If Condition of this loop. So that you don't get the same values again.
UPDATED: Okay I updated one last time. As mentioned, I don't know what you want to do with the extra values... but this function will output them where ever...?
good luck.
Here's a custom function that matches what you're looking for, it will return the first time that 120 appears in a cell...
Here's one more that you could use if you truly wanted "contains" only a partial match.
Function SuperSearcherTHING(ivalue As Variant, theColumn As Range) As String
Dim rCell As Range
Const theSPACER As String = "|"
For Each rCell In Intersect(theColumn.EntireColumn, theColumn.Worksheet.UsedRange).Cells
If InStr(1, rCell.Value, ivalue, vbTextCompare) > 0 Then
SuperSearcherTHING = rCell.Value & theSPACER & SuperSearcherTHING
End If
Next rCell
SuperSearcherTHING = Left(SuperSearcherTHING, Len(SuperSearcherTHING) - Len(theSPACER))
End Function
Here is VBA I use to automatically insert page breaks while printing to pdf. Code seems to work if there is more than one page. However if there is only page in document debugger gives an error
Run-time error 9: Subscript out of range
pointing to Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1). Any ideas what is the problem and how to repair it?
Here is my code:
Sub Print()
Dim Cell As Range
Dim tempFolderPath As String
Dim filePath As String
Dim fileTitle As String
Dim fnd As Range, r As Range, pb As Variant
Dim PrintVersion As Worksheet
Dim WData As Worksheet
Dim rw As Range, hideRange As Range
Set PrintVersion = ThisWorkbook.Sheets("Print version")
Set WData = ThisWorkbook.Sheets("Data")
With PrintVersion.Range("Print_Area")
With .Cells.Rows
.WrapText = True
.VerticalAlignment = xlCenter
.EntireRow.AutoFit
End With
' Hide blank rows with formulas giving as a result ""
For Each rw In .Rows
For Each Cell In rw.Cells
If Cell.HasFormula Then
If Cell.Value = "" Then
If Not rw.Hidden Then
If hideRange Is Nothing Then
Set hideRange = rw
Else
Set hideRange = Union(hideRange, rw)
End If
Exit For ' no need to process rest of the row
End If
End If
End If
Next
Next
If Not hideRange Is Nothing Then hideRange.EntireRow.Hidden = True
End With
' Set print area till the last cell
PrintVersion.PageSetup.PrintArea = PrintVersion.Range("A1:C" & _
PrintVersion.[LOOKUP(2,1/(C1:C250<>""),ROW(C1:C250))]).Address
' make sure sheet is in page break view
PrintVersion.Parent.Windows(1).View = xlPageBreakPreview
' first clear any set page breaks
PrintVersion.ResetAllPageBreaks
' move preposed breaks to top of segement
With PrintVersion.HPageBreaks
pb = 1
Do
' check if first column is empty
Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1)
If r.Value = "" Then
' find previous cell in column 1 which is not empty
Set fnd = PrintVersion.Columns(1).Find("*", r, , , , xlPrevious)
' set page break 1 row above it
Set .Item(pb).Location = fnd.Offset(-1, 0)
DoEvents
End If
pb = pb + 1
If pb > .Count Then Exit Do
Loop
End With
' create a path for a temporary file
tempFolderPath = Environ("Temp")
fileTitle = "CV_" & Sheets("Filling form").Range("F7") & "_" & Sheets("Filling form").Range("F9")
filePath = tempFolderPath & "\" & fileTitle & ".pdf"
PrintVersion.ExportAsFixedFormat xlTypePDF, filePath, xlQualityStandard, True, , , , False
Set PrintVersion = Nothing
Set WData = Nothing
End Sub
So if there are no pagebreaks you do not need to handle them, right? Check if there are any before going into it:
With PrintVersion.HPageBreaks
If .Count > 0 Then
pb = 1
Do
' check if first column is empty
Set r = PrintVersion.Cells(.Item(pb).Location.Row, 1)
If r.Value = "" Then
' find previous cell in column 1 which is not empty
Set fnd = PrintVersion.Columns(1).Find("*", r, , , , xlPrevious)
' set page break 1 row above it
Set .Item(pb).Location = fnd.Offset(-1, 0)
DoEvents
End If
pb = pb + 1
If pb > .Count Then Exit Do
Loop
End If
End With
(not tested)
I am fairly new to VBA . I have been trying to get this code working to no avail, basically I have a search to find a value (That part is working) and I want to copy that value and the row where this value is located into another sheet on the next empty row and date stamp it. Any help will be appreciated. Many Thanks.
This a sample of the table:
Sample Table
This is the code I have half working:
Sub FindingValues()
Dim val As String
Dim result As String
Dim firstAddress As String
Dim c As Range
val = InputBox("Enter ID")
Set c = Sheets("Sheet1").Range("E:E").Find(val, LookIn:=xlValues, _
MatchCase:=False)
If Not c Is Nothing Then
firstAddress = c.Address
' Application.Goto c
Copy.Sheets(Sheet2).c
Set c = Cells.FindNext(c)
Else
If c Is Nothing Then
MsgBox "Could Not Find " & Res
End If
End If
I think this should do it...
Sub FindingValues()
Dim val As String, result As String, firstAddress As String, entryROW As Long
Dim c As Range
'PGCodeRider making assumption to inser in column A
Dim columnNumberToPasteData As Long
columnNumberToPasteData = 1
'assumes Sheet2 is where data should be copied
Dim WS2 As Worksheet
Set WS2 = Sheets("Sheet2")
val = InputBox("Enter ID")
'probably want something like this so that if user wants to cancel
If val = "" Then Exit Sub
Set c = Sheets("Sheet1").Range("E:E").Find(val, LookIn:=xlValues, _
MatchCase:=False)
If Not c Is Nothing Then
entryROW = WS2.Cells(Rows.Count, columnNumberToPasteData).End(xlUp).Row + 1
WS2.Rows(entryROW).Value = c.Worksheet.Rows(c.Row).Value
WS2.Cells(entryROW, Columns.Count).End(xlToLeft).Offset(0, 1).Value = VBA.Now
' With WS2.Cells(entryROW, columnNumberToPasteData)
' .Offset(0, 0).Value = c.Value
' .Offset(0, 1).Value = c.Row
' .Offset(0, 2).Value = Now()
' End With
'
Else
If c Is Nothing Then MsgBox "Could Not Find " & val
End If
End Sub