I have a code that can generate page number on cells.
But I want it apply to mutiple cells in one time instead of single cells.
Sub pagenumber()
'updateby Extendoffice 20160506
Dim xVPC As Integer
Dim xHPC As Integer
Dim xVPB As VPageBreak
Dim xHPB As HPageBreak
Dim xNumPage As Integer
xHPC = 1
xVPC = 1
If ActiveSheet.PageSetup.Order = xlDownThenOver Then
xHPC = ActiveSheet.HPageBreaks.Count + 1
Else
xVPC = ActiveSheet.VPageBreaks.Count + 1
End If
xNumPage = 1
For Each xVPB In ActiveSheet.VPageBreaks
If xVPB.Location.Column > ActiveCell.Column Then Exit For
xNumPage = xNumPage + xHPC
Next
For Each xHPB In ActiveSheet.HPageBreaks
If xHPB.Location.Row > ActiveCell.Row Then Exit For
xNumPage = xNumPage + xVPC
Next
ActiveCell = "Page " & xNumPage & " of " & Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")
End Sub
What can i do for this? Is it also possible for apply the code to highlighted cells?
At the end write this:
Range("A1:B10")="Page "&xNumPage&" of "& Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")
Instead of:
ActiveCell = "Page "&xNumPage& " of " & Application.ExecuteExcel4Macro("GET.DOCUMENT(50)")
Making sure that Range("A1:B10") is the range to which you want to apply the numbers.
How to avoid using Select in Excel VBA
Related
Any help here would be appreciated please.
The included VBA code almost meets the intended purpose, however, I need a solution that enables the use of wildcards and highlights all parameters contained between "##", "%%" or potentially other special characters (special characters included).
For instance, lets say in the cell range B2:B10 we would find something like:
Checked at ##date1## and ##hour1##
But I want to be able to do a search and highlight using # * # or % * % within a selected determined cell range with the end result (bold being color):
Checked at ##date1## and ##hour1##
Sub HighlightStrings()
Application.ScreenUpdating = False
Dim Rng As Range
Dim cFnd As String
Dim xTmp As String
Dim x As Long
Dim m As Long
Dim y As Long
Dim xFNum As Integer
Dim xArrFnd As Variant
Dim xStr As String
cFnd = InputBox("Please enter the text, separate them by comma:")
If Len(cFnd) < 1 Then Exit Sub
xArrFnd = Split(cFnd, ",")
For Each Rng In Selection
With Rng
For xFNum = 0 To UBound(xArrFnd)
xStr = xArrFnd(xFNum)
y = Len(xStr)
m = UBound(Split(Rng.Value, xStr))
If m > 0 Then
xTmp = ""
For x = 0 To m - 1
xTmp = xTmp & Split(Rng.Value, xStr)(x)
.Characters(Start:=Len(xTmp) + 1, Length:=y).Font.ColorIndex = 3
xTmp = xTmp & xStr
Next
End If
Next xFNum
End With
Next Rng
Application.ScreenUpdating = True
End Sub
Thank you
Okay This seems to work for me. There is a limitation we can work on if required: the phrase to highlight must be padded with spaces on both sides.
Option Explicit
Option Base 0
Sub testreplace()
Dim I As Integer 'Iteration
Dim FlagNum As Integer 'Flag Number
Dim RG As Range 'Whole range
Dim CL As Range 'Each Cell
Dim FlagChar As String 'Flag characters
Dim ArrFlag 'Flag Char Array
Dim TextTemp As String 'Cell Contents
Set RG = Selection
FlagChar = "##"
FlagChar = InputBox("Enter 'Flag Characters' separated by a comma." & vbCrLf & vbCrLf & _
"Example:" & vbCrLf & vbCrLf & _
"##,%%,&&" & vbCrLf & _
"$$,XX", "Flag Characters to Highlight", "##,%%")
ArrFlag = Split(FlagChar, ",")
For Each CL In RG.Cells
TextTemp = CL.Value
For FlagNum = 0 To UBound(ArrFlag)
For I = 1 To Len(TextTemp)
'Debug.Print "<<" & Mid(TextTemp, I, Len(ArrFlag(Flagnum)) + 1) & _
"=" & " " & ArrFlag(Flagnum) & ">>"
If Mid(TextTemp, I, Len(ArrFlag(FlagNum)) + 1) = " " & ArrFlag(FlagNum) Then
CL.Characters(I + 1, InStr(I, TextTemp, ArrFlag(FlagNum) & " ") + _
Len(ArrFlag(FlagNum)) - I).Font.ColorIndex = 3
End If
Next I
Next FlagNum
Next CL
End Sub
Here's an example of it working:
In my VBA code below it searches for any cell for red to delete. The line is at
Dim colors_to_delete As String: colors_to_delete = "red"
What would I add to this code so it delete red and blue?
Sub collapse_columns()
Dim x As Integer
For x = 1 To 4
collapse_column x
Next
End Sub
Sub collapse_column(column_number As Integer)
Dim row As Long
Dim s As Worksheet
Dim last_row As Long
Set s = ActiveSheet ' work on the active sheet
'Set s = Worksheets("Sheet1") 'work on a specific sheet
last_row = s.Cells(s.Rows.Count, column_number).End(xlUp).row
Dim colors_to_delete As String: colors_to_delete = "red"
For row = last_row To 1 Step -1
If InStr(1, " " & s.Cells(row, column_number).Value & " ", " " & colors_to_delete & " ") > 0 Then
s.Cells(row, column_number).Delete xlUp
End If
Next row
End Sub
You could use an array of color names:
Sub collapse_column(column_number As Integer)
Dim row As Long
Dim s As Worksheet
Dim last_row As Long, clr, c as Range
Set s = ActiveSheet ' work on the active sheet
last_row = s.Cells(s.Rows.Count, column_number).End(xlUp).row
For row = last_row To 1 Step -1
Set c = s.Cells(row, column_number)
For Each clr in Array("red", "blue") '<< array to check against
If InStr(1, " " & c.Value & " ", " " & clr & " ") > 0 Then
c.Delete xlUp
Exit For 'stop checking
End If
Next clr
Next row
End Sub
I get a mismatch error in this line :
row_str = Join(cell_rng, Chr(10))
Thank you. I am intermediate.
I attached a piece of the code below:
Dim last_row As String
Dim last_col As String
Dim office_str As String
Dim lookupVal As String
Dim i As Long
Dim seperate_cells, cell_rng As Range
Dim r As Range
Dim row_str As String
With Contacts
For i = 2 To last_row
Set cell_rng = Rows(i & ":" & i + 1)
For Each r In cell_rng.Rows
seperate_cells = cellsSeparator(r.SpecialCells(xlCellTypeConstants))
If row_str = "" Then
row_str = Join(cell_rng, Chr(10))
Else
row_str = row_str & vbLf & Join(cell_rng, Chr(10))
End If
Next
Debug.Print row_str
Client_Finder.result.Text = Client_Finder.result.Text & vbLf & row_str
Next i
End With
````
Please try the next way. It will place the values of the necessary specific row in the text box, each value separated by " | ":
Sub testSeparatorsBetweenRowCells()
'your existing code...
Dim arr, rngR As Range
For i = 2 To last_row
lookupVal = cells(i, office_str)
' Compare ComboBox with the range from the spreadsheet
If lookupVal = Office_Code Then
Set rngR = rows(i & ":" & i).SpecialCells(xlCellTypeConstants) 'Set a range which will return all cells value in the row, except the empty ones
arr = arrCells(rngR) 'call a function able to make an array from the range set in the above line
Client_Finder.result.Text = Client_Finder.result.Text & vbLf & Join(arr, " | ") 'add the text obtained by joining the array to the next line of existing text
End If
Next i
End Sub
Function arrCells(rng As Range) As Variant
Dim arr, Ar As Range, i As Long, C As Range
ReDim arr(rng.cells.count - 1) 'ReDim the array to be filled as the range cells number.
'- 1, because the array is 0 based...
For Each Ar In rng.Areas 'iterate between the range areas
For Each C In Ar.cells 'iterate between cells of each area
arr(i) = C.value: i = i + 1 'put each cell value in the array
Next
Next
arrCells = arr 'make the function returning the arr
End Function
If the text in the text box still goes on the next line, try making the text box property WordWrap False. If you cannot see all the text, make the textbox wider or decrease its font size.
Please, test it and send some feedback.
Edited:
Please, try understanding the next piece of code, able to deal with copying more rows at once:
Sub testCopyingMoreRows()
Dim sh As Worksheet, i As Long, rng As Range, r As Range, arr, strRow As String
Set sh = ActiveSheet
i = 9
Set rng = sh.rows(i & ":" & i + 1)
'you ca select cells, rows (even not consecutive) and use:
'Set rng = Selection.EntireRow 'just uncomment this code line...
'extract rows and paste their contents (exept the empty cells) in Imediate Window
For Each r In rng.rows
arr = arrCells(r.SpecialCells(xlCellTypeConstants))
If strRow = "" Then
strRow = Join(arr, " | ")
Else
strRow = strRow & vbLf & Join(arr, " | ")
End If
Next
Debug.Print strRow
'instead returning in Imediate Window, you can do it in your text box (uncomment the next line):
'Client_Finder.result.Text = Client_Finder.result.Text & vbLf & strRow
End Sub
The code uses the same function arrCells...
I'am on VBA trying to create a macro that record in different cell the number of times the workbook is open. Each time it is open, it creates a new cell with the number of the opening. So I created a counter for that.
Option Explicit
Dim i As Integer
Private Sub Workbook_Open()
If i = "" Then
i = 1
End If
ThisWorkbook.Worksheets("Feuil1").Cells(i, 1).Value = "Session " & i
i = i + 1
Debug.Print i
End Sub
However, the statement If i = "" remains highlighted in yellow, and I don't understand why...
Would someone have a solution?
Thank you !
i is an Integer so comparison to an empty String is not valid.
The closest thing you can do is
If i = 0 Then
But if you want the value to i to persist when you save the workbook, the simplest thing to do is to read its value from the workbook.
Of course you cannot assign a string to an integer. This is a type mismatch error.
What you need is to fetch the last cell in the column and then increment it.
Private Sub Workbook_Open()
' Fetch the last cell from column 1
Dim r As Range
With ThisWorkbook.Worksheets("Feuil1")
Set r = .Cells(.Rows.Count, 1).End(xlUp)
End With
' Get the last session number, or 0 if not present or doesn't match
Dim lastSession As Long: lastSession = 0
If Not IsEmpty(r) Then
Dim p As Long: p = InStr(1, Trim(r.value), "Session ")
If p = 1 Then
lastSession = CLng(Mid(r.value, p + Len("Session "), 10000))
End If
End If
r.Offset(1).value = "Session " & (lastSession + 1)
End Sub
I'd go like follows
Private Sub Workbook_Open()
With Worksheets("Feuil1")
With .Cells(.Rows.Count, 1).End(xlUp)
.Offset(1) = "Session " & Val(Replace(.Value, "Session ", "")) + 1
End With
End With
End Sub
I have been trying to write a program that will loop through all the cells in an excel sheet and if one starts with a '#' it should display a message. here's the code:
(template is a worksheet variable)
Private Function processTemplate()
Dim total As Long
total = template.UsedRange.count
Dim count As Integer
count = 0
While count <= total
If template.Cells(count).Value Like "[#]*" Then 'Here I get a error
MsgBox "Found #"
End If
count = count + 1
Wend
End Function
I have isolated the error to using a variable inside of cells(). If I replace count with some number (like 8) it works fine. I am getting error 1004 on the line If template.Cells(count).Value Like "[#]*" Then
If I make total an Integer it has the same error at the same place. After about 2-3 hrs of research/banging my head on the wall I have no idea. I initially got the error when assigning template.cells(row, col).Value to a string variable.
Here's my code now:
Private Sub processTemplate()
MsgBox Len("")
Dim str As String
Dim rows As Long
Dim cols As Long
rows = template.UsedRange.Height
cols = template.UsedRange.Width
Dim row As Integer
row = 1
While row < rows
Dim col As Integer
col = 1
While col < cols
str = template.Cells(row, col).Text
If Len(str) > 0 Then
If Left(template.Cells(row, col).Text, 1) = "#" Then
MsgBox "Found IT"
End If
End If
Rem MsgBox template.Parent.Name & ": " & template.Name & ", Cell(" & row & ", " & col & "): " & template.Cells(row, col).Value
col = col + 1
Wend
row = row + 1
Wend
End Sub
Now I get the error on str = template.Cells(row, col).Text
We can use a sub rather than a function
We loop over all the cells in UsedRange looking for a # as the first character in the cell.
Sub FindThePound()
Dim r As Range, pound As String, template As Worksheet
pound = "#"
Set template = ActiveSheet
For Each r In template.UsedRange
If Left(r.Value, 1) = pound Then
MsgBox "Found # in " & r.Address(0, 0)
End If
Next r
End Sub
EDIT#1
This version loops over all the cells, but does not test cells containing formulas
Sub FindThePound()
Dim r As Range, pound As String, template As Worksheet
pound = "#"
Set template = ActiveSheet
For Each r In template.UsedRange
If r.HasFormula = False Then
If Left(r.Value, 1) = pound Then
MsgBox "Found # in " & r.Address(0, 0)
End If
End If
Next r
End Sub
You could use find/ find next function which i guess bit faster than looping through each cell and do string comparison.
With Worksheets(1).Range("a1:a500") 'Provide the search range
Set c = .Find(2, lookin:=xlValues) ' searching for 2 in cell value
If Not c Is Nothing Then
firstAddress = c.Address 'first occurance
Do
'do whatever you want to do with the matches even replace them
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Reference:
http://msdn.microsoft.com/en-us/library/office/ff196143(v=office.15).aspx