Page 1 of 2 12 LastLast
Results 1 to 15 of 24
  1. #1
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,641
    Thanks
    115
    Thanked 652 Times in 594 Posts

    VB Code Repository

    This thread has been moved to another forum
    Last edited by Maudibe; 2013-03-23 at 12:15.

  2. The Following 4 Users Say Thank You to Maudibe For This Useful Post:

    13ILGal (2013-03-20),Dick-Y (2012-12-27),Kevin@Radstock (2012-12-28),motivated (2012-12-28)

  3. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Another take on Reverse - Compare and learn some new tricks.

    Note: You can almost always accomplish a task in more than way.

    Code:
    Option Explicit  'Forces Variables to be Declared
    
    Function Reverse(zSource As String) As String
    
       Dim lStrLen As Long  'Declare Variable to hold String Length
       Dim lCntr   As Long  'Declare Variable for For Loop Counter
       
       lStrLen = Len(zSource) 'Set string length in variable
       zSource = Trim(zSource) 'Delete leading/trailing spaces
       
       For lCntr = lStrLen To 1 Step -1  'Run loop backwards starting with
                                         'last character of string to first.
                                         'Quit when lCntr = 0
          Reverse = Reverse & Mid(zSource, lCntr, 1) 'Build new string one
                                                     'character at a time.
       Next lCntr   'Increment loop counter and go back to For stmt.
       
    End Function    'Reverse
    Excel Reverse String Function.PNG
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  4. #3
    WS Lounge VIP rory's Avatar
    Join Date
    Dec 2000
    Location
    Burwash, East Sussex, United Kingdom
    Posts
    6,280
    Thanks
    3
    Thanked 191 Times in 177 Posts
    Third option to reverse text:
    Code:
    Function ReverseText(strInput As String) As String
        ReverseText = VBA.StrReverse(strInput)
    End Function
    Regards,
    Rory

    Microsoft MVP - Excel

  5. The Following User Says Thank You to rory For This Useful Post:

    RetiredGeek (2012-12-28)

  6. #4
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Maudibe,

    The above code has one too many "End if" statements.
    Here's a slightly revised version that also centers the check marks.

    Code:
    Option Explicit
    
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
       '*** Test for more than one cell seleted or not in check mark range ***
       If Target.Cells.Count > 1 Or _
          Intersect(Target, Range("B3:F12")) Is Nothing Then Exit Sub
       
         Target.Font.Name = "Marlett"               'CHANGE THE FONT OF THE SELECTED CELL TO MARLETT
         
         If Target.Value = vbNullString Then      'IF THE SELECTED CELL IS EMPTY THEN...
           Target = "a"                                      'PLACE A CHECKMARK
           Target.HorizontalAlignment = xlCenter
         Else                                                    'IF IT IS NOT EMPTY THEN....
           Target = vbNullString                        'MAKE IT EMPTY
         End If
     
    End Sub
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  7. #5
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Here's a slightly more concise version that eliminates the case sensitive problem.
    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
    
      Sheets("Sheet3").Visible = Not (UCase([A1]) = "YES")
    
    End Sub
    Note this needs to be placed in a sheet module other than Sheet3 or you will not be able to unhide it once hidden since it isn't visible to change cell A1! Unless of course you change Sheet3!A1 via code.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  8. #6
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Maud,

    Here's a slightly changed version that gets rid of the file extension which could confuse some into thinking it is actually the Excel file.
    If you place this code in a module in your Personal.xls file or Personal.xlsm in 2007+ you can use it on any workbook.

    Code:
    Sub CreateDesktopShortCut()
    
       Dim oWSH         As Object
       Dim oShortcut    As Object
       Dim zPathDeskTop As String
       Dim vNameOnly    As Variant
       
       vNameOnly = Split(ActiveWorkbook.Name, ".") 'Get Rid of File Extension
       Set oWSH = CreateObject("WScript.Shell")
       zPathDeskTop = oWSH.SpecialFolders("Desktop")
       Set oShortcut = oWSH.CreateShortCut(zPathDeskTop & "\" & _
          vNameOnly(0) & ".lnk")
          
       With oShortcut
           .TargetPath = ActiveWorkbook.FullName
           .Save
       End With
       
       Set oWSH = Nothing
       
    End Sub          'CreateDesktopShortCut()
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  9. #7
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,832
    Thanks
    136
    Thanked 484 Times in 461 Posts
    re: Hide/Unhide sheet based on cell value

    Hi RG!
    Here's an even more concise version:

    Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Sheet3.Visible = Not (UCase([A1]) = "YES")
    End Sub

    Place this in the ThisWorkbook module.
    This uses the default code name for "Sheet3", which means that even if you doubleclick and change the tab name it will still work whenever you type Yes in cell [a1] on any sheet

    zeddy

  10. #8
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    To initialize the RefEdit control to the currently selected range when the form is opened place this code in the form:
    Code:
    Private Sub UserForm_Initialize()
    
       Me.RefEdit1.Value = Selection.Address(, xlA1)
       
    End Sub
    Initialize RefEdit Control.PNG

    To initialize when the control is entered use:
    Code:
    Private Sub RefEdit1_Enter()
    
       RefEdit1.Value = Selection.Address(, xlA1)
       
    End Sub
    Last edited by RetiredGeek; 2013-01-19 at 19:56.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  11. #9
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts

    Selectively Execute Startup Code

    If you want to selectively execute VBA startup code, or any other code for that matter, you can caputure the User Name and Computer Name as follows:
    Code:
        zUName = Environ("USERNAME")
        zCompName = Environ("COMPUTERNAME")
    Then test the value of zUName or zCompName and decide what to do.
    Placed in the Auto_Open() event of an excel workbook you can easily have the code skipped for say the developer with:
    Code:
    Sub Auto_Open()
    
         Dim zUName as String
    
         zUName = Environ("USERNAME")
         if zUName = "{developer's user name here}" then Exit Sub
    
    '  Normal Auto_Open() code would appear below
    
    End Sub   'Auto_Open()
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  12. #10
    5 Star Lounger
    Join Date
    Jan 2004
    Location
    Praha
    Posts
    990
    Thanks
    56
    Thanked 106 Times in 91 Posts

    Neat labels on a chart

    It is all very well using Excel chart labels . . . but if there are lots of data points the chart can become a sea of illegible over-writing.

    This elegant piece of code labels each series in a chart but only at the last data point - try it and see, its like a legend but written alongside each series instead of being off at the side somewhere.

    As it is written, the macro will operate on whatever chart is active, but it is easily adapted to target a specific chart.

    Locate the code in any general module and run it like any other macro.

    Credit to the author, Jon Peltier http://peltiertech.com/WordPress/lab...es-in-a-chart/ and freely available for non-commercial use.

    Code:
    Sub LastPointLabel()
    ' On whatever chart is active, this Macro puts Series Labels on the right-handmost data points only and removes any Legend
      Dim mySrs As Series
      Dim iPts As Long
      Dim vYVals As Variant
      Dim vXVals As Variant
    
      If ActiveChart Is Nothing Then
        MsgBox "Select a chart and try again.", vbExclamation
      Else
        Application.ScreenUpdating = False
        For Each mySrs In ActiveChart.SeriesCollection
          With mySrs
            vYVals = .Values
            vXVals = .XValues
            ' clear existing labels
            .HasDataLabels = False
            For iPts = .Points.Count To 1 Step -1
              If Not IsEmpty(vYVals(iPts)) And Not IsError(vYVals(iPts)) _
                  And Not IsEmpty(vXVals(iPts)) And Not IsError(vXVals(iPts)) Then
                ' add label
                mySrs.Points(iPts).ApplyDataLabels _
                    ShowSeriesName:=True, _
                    ShowCategoryName:=False, ShowValue:=False, _
                    AutoText:=True, LegendKey:=False
                Exit For
              End If
            Next
          End With
        Next
        ' legend is now unnecessary
        ActiveChart.HasLegend = False
        Application.ScreenUpdating = True
      End If
    End Sub
    Last edited by MartinM; 2013-01-23 at 17:36.

  13. #11
    5 Star Lounger
    Join Date
    Jan 2004
    Location
    Praha
    Posts
    990
    Thanks
    56
    Thanked 106 Times in 91 Posts

    SUBTOTALIF( range, criteria, [sum_range] )

    SUMIF can be a useful function but unfortunately Excel doesn't have a built in SUBTOTALIF equivalent.

    A few years ago I worked with Forum contributor Don Wells on a UDF which creates the exact equivalent . . . just place this code in This Workbook module (pretty well anywhere will do, but that is a logical place for a UDF).

    Then you can use the function SUBTOTALIF( range, criteria, [sum_range] ) in a formula with the same criteria, and limitations, as SUMIF( range, criteria, [sum_range] ).

    Code:
    Function SubTotalIf(rngRange As Range, crit As Variant, rngVal As Range)
    Dim Subt As Double
    Dim rcell As Range
    Dim vcell As Range
    Dim n As Long
    
      n = 1
      For Each rcell In rngRange
        If Left(rngVal.Cells(n).Formula, 10) = "=SUBTOTAL(" _
          And UCase(rcell) = UCase(crit) Then
          Subt = Subt + rngVal.Cells(n)
        End If
        n = n + 1
      Next rcell
      SubTotalIf = WorksheetFunction.SumIf(rngRange, crit, rngVal) - Subt
    End Function
    Last edited by MartinM; 2013-01-24 at 13:47.

  14. #12
    5 Star Lounger
    Join Date
    Jan 2004
    Location
    Praha
    Posts
    990
    Thanks
    56
    Thanked 106 Times in 91 Posts

    Quirky behaviour when inserting rows

    Formulas which address a column of cells (SUM, SUMIF, SUBTOTAL, SUMPRODUCT, COUNT etc etc) can produce unexpected results when you insert a row - the result depends on where you make the insertion, and what the cells above and below the insertion contain.

    This can lead to significant errors, and they are hard to spot.

    Forum contributor Rory solved this for me with a neat workaround.

    Create a Name [Insert . . . Name . . . Define] called CellAbove. In the Refers to: box type =INDIRECT("R[-1]C",0)

    Then, for example, instead of a formula in cell A21 such as SUM(A5:A20), use this: SUM(A5:CellAbove).
    Last edited by MartinM; 2013-01-24 at 12:16.

  15. The Following User Says Thank You to MartinM For This Useful Post:

    simmo7 (2013-01-24)

  16. #13
    5 Star Lounger
    Join Date
    Jan 2004
    Location
    Praha
    Posts
    990
    Thanks
    56
    Thanked 106 Times in 91 Posts
    If you want to extract just the numerical digits from a cell (useful, for instance, when parsing part numbers and the like) . . . .

    Open the VB environment (ALT F11) and insert a new Module in which you put the following code:

    Code:
    Function JustNumerics(ByVal Rng As String)
    Dim x As Object
    Set x = CreateObject("VBScript.RegExp")
    With x
        .Pattern = "\D"
        .Global = True
        JustNumerics = .Replace(Rng, "")
    End With
    End Function
    Then, in a formula, just use the function JUSTNUMERICS().

    You can adapt this method to simplify a wide range of string functions, for instance . . .

    Code:
    .Pattern = "\d{12}"
    . . . will extract any 12-digit numbers embedded in a string.

    The full syntax for Regular Expressions is here: http://www.regular-expressions.info/reference.html
    Last edited by MartinM; 2013-01-26 at 06:17.

  17. #14
    Silver Lounger
    Join Date
    Jan 2001
    Location
    West Long Branch, New Jersey, USA
    Posts
    1,921
    Thanks
    6
    Thanked 9 Times in 7 Posts

    Loop Thru All Worksheets

    Following code loops through all the worksheets in a workbook. You can put whatever code you need for accomplishing the task needed to be done on each sheet. Here, the zoom is set.

    Code:
    Option Explicit  'Forces Variables to be Declared
    
    Sub all_sheets ()
    Dim wks as Worksheet      'wks is a variable representing each sheet as you loop through the collection of sheets
    
    For Each wks in Worksheets    'Worksheets is a collection of all the sheets in the Worksbook and is maintained by Excel
    
      wks.Select
      ActiveWindow.Zoom = 120     'sets the Zoom to 120 (like using the Zoom drop-down box or slider in Excel) 
    
    Next
    
    End

  18. #15
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Maud,

    Here's a slight variation which does things slightly differently. Not better or worse just different.
    As I'm wont to say "It all depends on how you look at it!"
    Code:
    Option Explicit
    
    Sub AddNewSheet()
    
       Dim wksCurSht    As Worksheet
       Dim zCurrentDate As String
       
       'Note: You could also use the underline in the format of the date
       zCurrentDate = Format(Now(), "mm-dd-yyyy") 'SET VARIABLE TO THE CURRENT DATE
       
       For Each wksCurSht In Worksheets
       
          If wksCurSht.Name = zCurrentDate Then  'IF A SHEET WITH THE CURRENT DATE ALREADY EXISTS THEN....
            MsgBox "A sheet named with the current date [ " & _
                zCurrentDate & " ] already exisis"
            Exit Sub
          End If
        
        Next wksCurSht  'IF NO SHEET WITH THE CURRENT DATE EXISTS
        
        'Create new sheet and assign to worksheet type object variable
        Set wksCurSht = Sheets.Add(After:=Sheets(Sheets.Count))
        
        'Assign sheet color and name using object variable
        'Note: Sheet color not Red when selected!
        wksCurSht.Tab.Color = RGB(255, 0, 0) 'CHANGE THE TAB COLOR TO RED
        wksCurSht.Name = zCurrentDate  'RENAME THE SHEET
        
    End Sub
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

Page 1 of 2 12 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •