New in Stack Overflow, I'm building a macro in Excel with VBA. Basically I have a file with multiple tabs with information in tables, these tables have text in it and some words from that text are bold and repeat in each tab (lets say owner and process). I do display of this information in a textbox located in a form according to the line of the table they pick before on a listbox, the text displays correctly but it ignore the text formatting(bold and italic). Is there a way to display the text formatting in the textbox as it is in the table?
Hope I've have made myself clear enough.
Typical example for a Shape textbox (not ActiveX):
Sub BoxMaker()
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 217.5, 51#, _
482.25, 278.25).Select
Selection.Name = "SPLASH"
Selection.Characters.Text = "Please Wait for Macro"
With Selection.Characters(Start:=1, Length:=21).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 36
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Characters(Start:=8, Length:=4).Font.Bold = True
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
End Sub
You can format text in a textbox similar to text in a cell.
Possible work around in UserForm using a Webbrowser control
Due to your comment: "...actually I'm using MSForms.TextBox"
A possible work around would be to create a simple HTML file using the b tag (e.g. blabla within normal textbold text ...) for bold text and load it into a Webbrowser control (needs reference to Microsoft Internet Controls) e.g. via WebBrowser1.Navigate ThisWorkbook.Path & "\topic.htm".
As HTML commonly uses utf-8 encoding I demonstrate an approach using the system function WideCharToMultiByte (API call).
Example call using helper functions (API calls)
' declare and assign simple html string
Dim htmlstring as String
htmlstring = "<html><body><div>Normal text <b>bold text</b> further text</div></body></html>"
' write html file via helper procedure
writeUtf8 htmlstring, ThisWorkbook.Path & "\topic.htm"
' load html file into WebBrowswer control
Me.WebBrowser1.Navigate ThisWorkbook.Path & "\topic.htm"
Helper procedures
I suggest to write a separate code module for these helper functions:
Option Explicit ' declaration head of separate code module
' Declare API Function
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
Public Sub writeUtf8(ByVal s As String, ByVal datei As String)
' Purpose: save HTML String in utf-8 mode
' Note: called by writeUtf8 htmlstring, thisworkbook.path & "\topic.htm"
Dim file As Integer
Dim B() As Byte
file = FreeFile
Open datei For Binary Access Write Lock Read Write As #file
getUtf8 s, B
Put #file, , B
Close #file
End Sub
Private Sub getUtf8(ByRef s As String, ByRef B() As Byte)
' Note: called by above helper function; uses API call (see declaration head)
Const CP_UTF8 As Long = 65001
Dim len_s As Long
Dim ptr_s As Long
Dim size As Long
Erase B
len_s = Len(s)
If len_s = 0 Then _
err.Raise 30030, , "Len(WideChars) = 0"
ptr_s = StrPtr(s)
size = WideCharToMultiByte(CP_UTF8, 0, ptr_s, len_s, 0, 0, 0, 0)
If size = 0 Then _
err.Raise 30030, , "WideCharToMultiByte() = 0"
ReDim B(0 To size - 1)
If WideCharToMultiByte(CP_UTF8, 0, ptr_s, len_s, VarPtr(B(0)), size, 0, 0) = 0 Then _
err.Raise 30030, , "WideCharToMultiByte(" & Format$(size) & ") = 0"
End Sub
Related
INTRO
With this code it is possible to display mathematical equation within a WORD document:
Sub genEQ()
Dim objRange As Range
Dim objEq As OMath
Dim AC As OMathAutoCorrectEntry
Application.OMathAutoCorrect.UseOutsideOMath = True
Set objRange = Selection.Range
objRange.Text = "Celsius = \sqrt(x+y) + sin(5/9 \times(Fahrenheit – 23 (\delta)^2))"
For Each AC In Application.OMathAutoCorrect.Entries
With objRange
If InStr(.Text, AC.Name) > 0 Then
.Text = Replace(.Text, AC.Name, AC.Value)
End If
End With
Next AC
Set objRange = Selection.OMaths.Add(objRange)
Set objEq = objRange.OMaths(1)
objEq.BuildUp
End Sub
An with this code I am able to display UNICODE characters within EXCEL message boxes without displaying "?" or "random characters":
Private Declare PtrSafe Function MessageBoxW Lib "User32" (ByVal hWnd As LongPtr, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal uType As Long) As Long
Public Function MsgBoxW(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String = "Microsoft Excel") As VbMsgBoxResult
MsgBoxW = MessageBoxW(Application.hWnd, StrPtr(Prompt), StrPtr(Title), Buttons)
End Function
QUESTION
Is there now a way to combine those and display a complete equation within a message box in EXCEL?
Further how do I refer to MS WORD with the above code snippet to be run within EXCEL?
Is there a way to display a fraction like in the formula of the first code without making a string with a " / "-symbol?
As stated by #GSerg, you need to go through an intermediary picture and use a userform rather than a message box.
The following code converts the text to a formula and goes via Publisher to save the picture then loads it into a pre-existing UserForm UserForm1 with image placeholder Image1. I have increased font size to get better resolution for the picture but this can be set to other values.
Updated to work with autocorrect formulae
Sub DisplayFormulae()
' Requires reference: Microsoft Word x.x Object Library
' Requires reference: Microsoft Publisher x.x Object Library
Dim sFormula As String: sFormula = "Celsius = \sqrt(x+y) + sin(5/9 \times(Fahrenheit – 23 (\delta)^2))"
Dim SaveName As String: SaveName = Environ("TEMP") & "\formula.jpg"
Dim AC As Word.OMathAutoCorrectEntry
Dim WordDoc As New Word.Document
With WordDoc
.Range.Text = sFormula
.Range.Font.Size = 18
For Each AC In .Parent.OMathAutoCorrect.Entries
With .Range
If InStr(.Text, AC.Name) > 0 Then
.Text = Replace(.Text, AC.Name, AC.Value)
End If
End With
Next AC
.OMaths.Add(.Range).OMaths(1).BuildUp
.OMaths(1).Range.Copy
.Close SaveChanges:=wdDoNotSaveChanges
End With
Dim PubDoc As New Publisher.Document
PubDoc.Pages(1).Shapes.Paste
PubDoc.Pages(1).Shapes(1).SaveAsPicture _
PbResolution:=pbPictureResolutionCommercialPrint_300dpi, _
Filename:=SaveName
PubDoc.Close
UserForm1.Controls("Image1").Picture = LoadPicture(SaveName)
UserForm1.Show
Kill SaveName
End Sub
I have created a custom page size for excel under "windows print server properties". following the steps given here https://www.win2pdf.com/doc/pdf-custom-paper-windows-10.html
Now I have all the custom sizes including default sizes shown in the excel page size list. next, I have pulled all sizes to excel Combobox dropdown with the following codes.
so my requirement is to change excel sheet size with Combobox selection change.
Please Note: we cannot change size with case method or predefine it unless sizes are fixed, as sizes will be dynamic in Combobox, once the user creates a new size it ll get added to Combobox.
Thanks
'worksheet code
ActiveSheet.ComboBox1.List = GetPaperSizes
'module code
Option Explicit
Private Const DC_PAPERNAMES = &H10
Private Declare Function DeviceCapabilities _
Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" _
(ByVal lpDeviceName As String, _
ByVal lpPort As String, _
ByVal iIndex As Long, _
ByRef lpOutput As Any, _
ByRef lpDevMode As Any) _
As Long
Private Declare Function StrLen _
Lib "kernel32.dll" _
Alias "lstrlenA" _
(ByVal lpString As String) _
As Long
Function GetPaperSizes() As Variant
Dim AllNames As String
Dim I As Long
Dim Msg As String
Dim PD As Variant
Dim Ret As Long
Dim papersizes() As Byte
Dim PaperSize As String
'Retrieve the number of available paper names
PD = Split(Application.ActivePrinter, " on ")'<<<== change "on" with its local Language translation from english
Ret = DeviceCapabilities(PD(0), PD(1), DC_PAPERNAMES, ByVal 0&, ByVal 0&)
'resize the array
ReDim papersizes(0 To Ret * 64) As Byte
'retrieve all the available paper names
Call DeviceCapabilities(PD(0), PD(1), DC_PAPERNAMES, papersizes(0), ByVal 0&)
'convert the retrieved byte array to an ANSI string
AllNames = StrConv(papersizes, vbUnicode)
'loop through the string and search for the names of the papers
For I = 1 To Len(AllNames) Step 64
PaperSize = Mid(AllNames, I, 64)
PaperSize = Left(PaperSize, StrLen(PaperSize))
If PaperSize <> vbNullString Then Msg = Msg & PaperSize & vbCrLf
Next I
GetPaperSizes = Split(Left(Msg, Len(Msg) - 2), vbCrLf)
End Function
can I expect any help on this? I am not sure this bump is right or not.
i am trying to get list of all available page sizes in combobox as dropdown with vba. when user select the size, i need to change the worksheet size accordingly. also in another combobox i need to populate width and height of that paper size when page size in combobox is selected.
I tried something like.
Dim i As integer
for i = 1 to 30
activesheet.combobox1.value = Activesheet.PageSetup.Papersize(i)
next i
Thanks
here's a solution based on This link
ActiveSheet.ComboBox1.List = GetPaperSizes
where GetPaperSizes is the following function you must place in a standard module:
Option Explicit
'Written: June 14, 2010
'Author: Leith Ross
'Summary: Lists the supported paper sizes for the default printer in a message box.
Private Const DC_PAPERNAMES = &H10
Private Declare Function DeviceCapabilities _
Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" _
(ByVal lpDeviceName As String, _
ByVal lpPort As String, _
ByVal iIndex As Long, _
ByRef lpOutput As Any, _
ByRef lpDevMode As Any) _
As Long
Private Declare Function StrLen _
Lib "kernel32.dll" _
Alias "lstrlenA" _
(ByVal lpString As String) _
As Long
Function GetPaperSizes() As Variant
Dim AllNames As String
Dim I As Long
Dim Msg As String
Dim PD As Variant
Dim Ret As Long
Dim papersizes() As Byte
Dim PaperSize As String
'Retrieve the number of available paper names
PD = Split(Application.ActivePrinter, " on ")'<<<== change "on" with its local Language translation from english
Ret = DeviceCapabilities(PD(0), PD(1), DC_PAPERNAMES, ByVal 0&, ByVal 0&)
'resize the array
ReDim papersizes(0 To Ret * 64) As Byte
'retrieve all the available paper names
Call DeviceCapabilities(PD(0), PD(1), DC_PAPERNAMES, papersizes(0), ByVal 0&)
'convert the retrieved byte array to an ANSI string
AllNames = StrConv(papersizes, vbUnicode)
'loop through the string and search for the names of the papers
For I = 1 To Len(AllNames) Step 64
PaperSize = Mid(AllNames, I, 64)
PaperSize = Left(PaperSize, StrLen(PaperSize))
If PaperSize <> vbNullString Then Msg = Msg & PaperSize & vbCrLf
Next I
GetPaperSizes = Split(Left(Msg, Len(Msg) - 2), vbCrLf)
End Function
I am developing an Excel add-in with a CHM help file. The CHM has topics that I am trying to reach from Excel's "Insert Function" dialog. This is confirmed when I invoke HH.EXE as follows:
HH.EXE -mapid 1234 "mk:#MSITSTORE:<path-to-my-chm-file>"
I registered all of my UDFs with the Application.MacroOptions( ) function, passing the appropriate parameters (Macro, Category, HelpContextID and HelpFile).
When I click the "Help on this function" link, HH.EXE is invoked with the correct path and file name of my CHM. However, there is no -mapid parameter used for the invocation of HH.EXE. Consequently, when my CHM file is loaded, HH does not go to the desired topic.
Does anyone know or have a guess as to why Excel may be omitting this parameter?
Thank you!
As I understand you want something like shown in the snapshot. Context-sensitive help is complex.
I add sample code for buttons and code for calling the HTMLHelp (CHM) API.
Office 2007 is installed on my machine only.
This is done by a HTMLHelp API call (code snippet (1)):
'******************************************************************************
'----- Modul - definition for HTMLHelp
'----- (c) Ulrich Kulle, http://www.help-info.de/en/Visual_Basic_Applications/vba.htm
'----- 2002-08-26 Version 0.2.xxx
'******************************************************************************
'----- Portions of this code courtesy of David Liske.
Declare Function IsWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function HtmlHelp Lib "hhctrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, _
ByVal uCommand As Long, ByVal dwData As Long) As Long
Declare Function HTMLHelpTopic Lib "hhctrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, _
ByVal uCommand As Long, ByVal dwData As String) As Long
Private Declare Function HtmlHelpSearch Lib "hhctrl.ocx" Alias "HtmlHelpA" _
(ByVal hwndCaller As Long, ByVal pszFile As String, _
ByVal uCommand As Long, dwData As HH_FTS_QUERY) As Long
'--- to keep the handle of the HH windows when calling help by API --------
Public HHwinHwnd As Long
'--- some constants used by the API ---------------------------------------
Public Const HH_DISPLAY_TOPIC = &H0 ' select last opened tab, [display a specified topic]
Public Const HH_DISPLAY_TOC = &H1 ' select contents tab, [display a specified topic]
Public Const HH_DISPLAY_INDEX = &H2 ' select index tab and searches for a keyword
Public Const HH_DISPLAY_SEARCH = &H3 ' select search tab and perform a search
Public Const HH_HELP_CONTEXT = &HF ' display mapped numeric value in dwData
Public Const HH_CLOSE_ALL = &H12
Public Type HH_FTS_QUERY ' UDT for accessing the Search tab
cbStruct As Long ' Sizeof structure in bytes.
fUniCodeStrings As Long ' TRUE if all strings are unicode.
pszSearchQuery As String ' String containing the search query.
iProximity As Long ' Word proximity.
fStemmedSearch As Long ' TRUE for StemmedSearch only.
fTitleOnly As Long ' TRUE for Title search only.
fExecute As Long ' TRUE to initiate the search.
pszWindow As String ' Window to display in
End Type
Public Function HFile(ByVal i_HFile As Integer) As String
'----- Set the string variable to include the application path of helpfile
Select Case i_HFile
Case 1
HFile = ThisWorkbook.Path & "\CHM-example.chm"
Case 2
'----- Place other Help file paths in successive case statements
HFile = ThisWorkbook.Path & "\CHM-example.chm"
End Select
End Function
Public Sub ShowContents(ByVal intHelpFile As Integer)
HHwinHwnd = HtmlHelp(hwnd, HFile(intHelpFile), HH_DISPLAY_TOC, 0)
End Sub
Public Sub ShowIndex(ByVal intHelpFile As Integer)
HHwinHwnd = HtmlHelp(hwnd, HFile(intHelpFile), HH_DISPLAY_INDEX, 0)
End Sub
Public Sub ShowTopic(ByVal intHelpFile As Integer, strTopic As String)
HHwinHwnd = HTMLHelpTopic(hwnd, HFile(intHelpFile), HH_DISPLAY_TOPIC, strTopic)
End Sub
Public Sub ShowTopicID(ByVal intHelpFile As Integer, IdTopic As Long)
HHwinHwnd = HtmlHelp(hwnd, HFile(intHelpFile), HH_HELP_CONTEXT, IdTopic)
End Sub
Public Sub CloseHelp(ByVal hwnd As Long)
Const WM_CLOSE = &H10
If IsWindow(hwnd) Then
SendMessage hwnd, WM_CLOSE, 0, 0
End If
End Sub
'------------------------------------------------------------------------------
'----- display the search tab
'----- bug: start searching with a string dosn't work
'------------------------------------------------------------------------------
Public Sub ShowSearch(ByVal intHelpFile As Integer)
Dim searchIt As HH_FTS_QUERY
With searchIt
.cbStruct = Len(searchIt)
.fUniCodeStrings = 1&
.pszSearchQuery = "foobar"
.iProximity = 0&
.fStemmedSearch = 0&
.fTitleOnly = 1&
.fExecute = 1&
.pszWindow = ""
End With
Call HtmlHelpSearch(0&, HFile(intHelpFile), HH_DISPLAY_SEARCH, searchIt)
End Sub
And some sample code (2) added:
Sub AddUDFToCategory()
'------------------------------------------------------------------------------
' insert after Description line [optional]: Category:=2, _ => Date & Time
'------------------------------------------------------------------------------
' If the UDF's are in an Addin (.xla) it's better to qualify the function name
' like this:
' Macro:=ThisWorkbook.Name & "!" & "DayName"
'------------------------------------------------------------------------------
' see also Excel help for Application.MacroOptions
'------------------------------------------------------------------------------
application.MacroOptions _
Macro:="TestMacro", _
Description:="This function gives back the 'Hello world' message!", _
Category:=2, _
HelpFile:=ThisWorkbook.Path & "\CHM-example.chm", _
HelpContextID:=10000
application.MacroOptions _
Macro:="DayName", _
Description:="A Function That Gives the Name of the Day", _
Category:=2, _
HelpFile:=ThisWorkbook.Path & "\CHM-example.chm", _
HelpContextID:=20000
End Sub
Function TestMacro()
'----------------------------------------------------------------
' Display a message box with a help button linked to a help topic
'----------------------------------------------------------------
MsgBox "The 'Hello World' message for testing this function!.", _
Buttons:=vbOKOnly + vbMsgBoxHelpButton, _
HelpFile:=ThisWorkbook.Path & "\CHM-example.chm", _
Context:=20010
End Function
Function DayName(InputDate As Date)
'---------------------------------------------
'--- A Function That Gives the Name of the Day
'--- http://www.fontstuff.com/vba/vbatut01.htm
'---------------------------------------------
Dim DayNumber As Integer
DayNumber = Weekday(InputDate, vbSunday)
Select Case DayNumber
Case 1
DayName = "Sunday"
Case 2
DayName = "Monday"
Case 3
DayName = "Tuesday"
Case 4
DayName = "Wednesday"
Case 5
DayName = "Thursday"
Case 6
DayName = "Friday"
Case 7
DayName = "Saturday"
End Select
End Function
For a working example go to Online Help and Visual Basic for Applications
please. Search for VBA - Download and the download link Download Visual Basic for Applications example project (EXCEL).
download the ZIP file from the link above to a temp directory, right click the saved ZIP file first, click Properties and click Unblock
unzip to a temp directory.
as a test open CHM file first by double click
double click CHM_VBA_example.xls
first have a look to security warnings ( Excel) and set to Activate
follow the instructions from the Excel example worksheet.
For further information read Using the VBA Excel Example File too.
I'd like to be able to copy a cell and paste ONLY number formats. Unfortunately, there is no built-in option in the PasteSpecial command.
Is there a way to press the copy button, select some destination cells, run a macro, and be able to retrieve the copied cells in a way analogous to the Selection object in VBA so that I can use its properties?
The only alternative I can think of is pasting to a known empty range (very far away) and then using that intermediate range, as below:
Dim A As Range
Set A = Range("ZZ99999")
A.PasteSpecial Paste:=xlPasteAll
Selection.NumberFormat = A.NumberFormat
Thanks!
Find olelib.tlb on the Internet (Edanmo's OLE interfaces & functions). There should be plenty of download links. Download and reference from your VBA project (Tools - References).
Note that it does not contain any executable code, only declarations of OLE functions and interfaces.
Also you might notice it's quite big, about 550kb. You can extract only the needed interfaces from it and recompile to get a much lighter TLB file, but that is up to you.
(If you are really unhappy with a TLB, there is also the dark magic route where you don't need any TLBs at all because you create assembly stubs on the fly to call vTable methods directly, but I won't be feeling like porting the below code this way.)
Then create a helper module and put this code into it:
Option Explicit
' No point in #If VBA7 and PtrSafe, as the Edanmo's olelib is 32-bit
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Public Function GetCopiedRange() As Excel.Range
Dim CF_LINKSOURCE As Long
CF_LINKSOURCE = olelib.RegisterClipboardFormat("Link Source")
If CF_LINKSOURCE = 0 Then Err.Raise 5, , "Failed to obtain clipboard format CF_LINKSOURCE"
If OpenClipboard(0) = 0 Then Err.Raise 5, , "Failed to open clipboard."
On Error GoTo cleanup
Dim hGlobal As Long
hGlobal = GetClipboardData(CF_LINKSOURCE)
If hGlobal = 0 Then Err.Raise 5, , "Failed to get data from clipboard."
Dim pStream As olelib.IStream
Set pStream = olelib.CreateStreamOnHGlobal(hGlobal, 0)
Dim IID_Moniker As olelib.UUID
olelib.CLSIDFromString "{0000000f-0000-0000-C000-000000000046}", IID_Moniker
Dim pMoniker As olelib.IMoniker
olelib.OleLoadFromStream pStream, IID_Moniker, pMoniker
Set GetCopiedRange = RangeFromCompositeMoniker(pMoniker)
cleanup:
Set pMoniker = Nothing 'To make sure moniker releases before the stream
CloseClipboard
If Err.Number > 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function
Private Function RangeFromCompositeMoniker(ByVal pCompositeMoniker As olelib.IMoniker) As Excel.Range
Dim monikers() As olelib.IMoniker
monikers = SplitCompositeMoniker(pCompositeMoniker)
If UBound(monikers) - LBound(monikers) + 1 <> 2 Then Err.Raise 5, , "Invalid composite moniker."
Dim binding_context As olelib.IBindCtx
Set binding_context = olelib.CreateBindCtx(0)
Dim WorkbookUUID As olelib.UUID
olelib.CLSIDFromString "{000208DA-0000-0000-C000-000000000046}", WorkbookUUID
Dim wb As Excel.Workbook
monikers(LBound(monikers)).BindToObject binding_context, Nothing, WorkbookUUID, wb
Dim pDisplayName As Long
pDisplayName = monikers(LBound(monikers) + 1).GetDisplayName(binding_context, Nothing)
Dim raw_range_name As String ' Contains address in the form of "!SheetName!R1C1Local", need to convert to non-local
raw_range_name = olelib.SysAllocString(pDisplayName)
olelib.CoGetMalloc(1).Free pDisplayName
Dim split_range_name() As String
split_range_name = Split(raw_range_name, "!")
Dim worksheet_name As String, range_address As String
worksheet_name = split_range_name(LBound(split_range_name) + 1)
range_address = Application.ConvertFormula(ConvertR1C1LocalAddressToR1C1(split_range_name(LBound(split_range_name) + 2)), xlR1C1, xlA1)
Set RangeFromCompositeMoniker = wb.Worksheets(worksheet_name).Range(range_address)
End Function
Private Function SplitCompositeMoniker(ByVal pCompositeMoniker As olelib.IMoniker) As olelib.IMoniker()
Dim MonikerList As New Collection
Dim enumMoniker As olelib.IEnumMoniker
Set enumMoniker = pCompositeMoniker.Enum(True)
If enumMoniker Is Nothing Then Err.Raise 5, , "IMoniker is not composite"
Dim currentMoniker As olelib.IMoniker
Do While enumMoniker.Next(1, currentMoniker) = olelib.S_OK
MonikerList.Add currentMoniker
Loop
If MonikerList.Count > 0 Then
Dim res() As olelib.IMoniker
ReDim res(1 To MonikerList.Count)
Dim i As Long
For i = 1 To MonikerList.Count
Set res(i) = MonikerList(i)
Next
SplitCompositeMoniker = res
Else
Err.Raise 5, , "No monikers found in the composite moniker."
End If
End Function
Private Function ConvertR1C1LocalAddressToR1C1(ByVal R1C1LocalAddress As String) As String
' Being extra careful here and not doing simple Replace(Replace()),
' because e.g. non-localized row letter may be equal to localized column letter which will lead to double replace.
Dim row_letter_local As String, column_letter_local As String
row_letter_local = Application.International(xlUpperCaseRowLetter)
column_letter_local = Application.International(xlUpperCaseColumnLetter)
Dim row_letter_pos As Long, column_letter_pos As Long
row_letter_pos = InStr(1, R1C1LocalAddress, row_letter_local, vbTextCompare)
column_letter_pos = InStr(1, R1C1LocalAddress, column_letter_local, vbTextCompare)
If row_letter_pos = 0 Or column_letter_pos = 0 Or row_letter_pos >= column_letter_pos Then Err.Raise 5, , "Invalid R1C1Local address"
If Len(row_letter_local) = 1 And Len(column_letter_local) = 1 Then
Mid$(R1C1LocalAddress, row_letter_pos, 1) = "R"
Mid$(R1C1LocalAddress, column_letter_pos, 1) = "C"
ConvertR1C1LocalAddressToR1C1 = R1C1LocalAddress
Else
ConvertR1C1LocalAddressToR1C1 = "R" & Mid$(R1C1LocalAddress, row_letter_pos + Len(row_letter_local), column_letter_pos - (row_letter_pos + Len(row_letter_local))) & "C" & Mid$(R1C1LocalAddress, column_letter_pos + Len(column_letter_local))
End If
End Function
Credits go to Alexey Merson.
Here's one way. Obviously you'll have to change the range to suit your situation, but it should get you the general idea:
Dim foo As Variant
foo = Sheet1.Range("A1:A10").NumberFormat
Sheet1.Range("D1:D10").NumberFormat = foo
Which really can be simplified to:
Sheet1.Range("D1:D10").NumberFormat = Sheet1.Range("A1:A10").NumberFormat
and if all of your formats in the range are the same, you can just do:
Sheet1.Range("D1:D10").NumberFormat = Sheet1.Range("A1").NumberFormat
Enough rambling...you get the idea.