Posts by ExcelJunkie

Sub Cyclecharts()
'USE - Cycle through charts and perform some formatting


'DEC VARS
    Dim i As Integer
    Dim ActChart As String


    'CODE
    On Error Resume Next 'In case Chart Object Error
    For i = 1 To ActiveSheet.ChartObjects.Count   'SET UP LOOP TO CYCLE CHARTS
        '**********LOOP************************ 
        Range("A2").Select    ' ENSURE NO OTHER CHART IS ACTIVATED
        ActChart = ActiveSheet.ChartObjects(i).Name    'STORE CHART NAME
        ActiveSheet.ChartObjects(i).Activate 'ACTIVATE THE CHART
        ActiveChart.ChartArea.Select 'SELECT CHART AREA
        ActiveChart.ChartTitle.Select 'SELECT TITLE
        With Selection.Font 'FORMAT TITLE
            .Size = 8
        End With
        '*********END LOOP **********************
    Next i 'NEXT CHART
End Sub

Sub CreatPivot()
    Call AutoPivot("Data", "Name", "Animal Type")
End Sub
Sub AutoPivot(strPivsheet As String, strPivCol1 As String, strPivCol2 As String)
'USE-EXCEL VBA CREATE SIMPLE PIVOT TABLE FROM COLUMNIZED DATA REGARDLESS OF NUMBER OF ROWS OR COLUMNS USING DYNAMIC RC NOTATION
'CREATED BY MARK SLOBODA
'DOWNLOAD COOL EXCEL STUFF :http://programminglibrary.com/Programming%20Library/DOWNLOAD/downloads.aspx


'************NOTES*****************************
'1)  ASSUMES DATA STARTS IN 1,1
'2)  IN THIS EXAMPLE YOU ARE USING VARIABLES TO MAKE DATA SOURCE SIZE OF NUMBER OF ROWS AND COLUMNS AND SHEET REGARDLESS OF SIZE
'3)  YOU COULD PASS AN ARRAY OF PIVOT COLUMN FIELD NAMES OR SIMPLY ADD OTHERS


'**************** VARS PASSED *****************
'strPivsheet - SHEET WHICH PIVOT TABLE WILL BE CREATED FROM
'strPivCol1 - PivotColumn1 (Used for Row and Data Fields)
'strPivCol2 - PivotColumn2 (Used for Column Field)


'DEC VARS
    Dim lngR As Long    '#ROWS-ALWAYS USE LONG TO AVOID MAX INTEGER ERROR
    Dim intC As Integer    '#COLUMNS


'SET VALS
    Sheets(strPivsheet).Select    'SELECT SHEET TO CREATE PIVOT TABLE ON
    Range("A1").Select    'SELECT A CELL IN ACTIVE DATA RANGE
    lngR = Range("A1").CurrentRegion.Rows.Count    'GET ROW COUNT ON ACTIVE SHEET
    intC = Range("A1").CurrentRegion.Columns.Count    'GET COLUMN COUNT ON ACTIVE SHEET


'BEGIN CODE
'CREATE THE PIVOT 2 VERSIONS


'******************* VERSION 1 NO SPECIFIC DESTINATION SHEET ********************************
'********************************************************************************************


'CREATE PIVOT
    ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:= _
                                 "'" & ActiveSheet.Name & "'!R1C1:R" & lngR & "C" & intC, TableDestination:="", TableName:="PivotTable1"


    'ADD CENTER DATA FIELD!!! IMPORTANT - DO THIS FIRST FOR PIVOT ROW AND COLUMN FIELDS TO WORK CORRECTLY - PASSED VARIABLE USED FOR PIVOT COLUMN
    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
                                                        "PivotTable1").PivotFields(strPivCol1), "Count of" & strPivCol1, xlCount


    'ADD ROW FIELD (LEFT HAND VERTICAL PART OF PIVOT TABLE) - PASSED VARIABLE USED FOR PIVOT ROW FIELD
    With ActiveSheet.PivotTables("PivotTable1").PivotFields(strPivCol1)
        .Orientation = xlRowField
        .Position = 1    'IMPORTANT ONLY IF MULTIPLE FIELDS ADDED
    End With


    'ADD COLUMN FIELD (TOP HORIZONTAL PART OF PIVOT TABLE) - PASSED VARIABLE USED FOR PIVOT COLUMN FIELD
    With ActiveSheet.PivotTables("PivotTable1").PivotFields(strPivCol2)
        .Orientation = xlColumnField
        .Position = 1    'IMPORTANT ONLY IF MULTIPLE FIELDS ADDED
    End With




    '******************* VERSION 2 SPECIFIC DESTINATION SHEET ********************************
    '*****************************************************************************************


    '    Sheets.Add    'CREATE A NEW SHEET OR ASSIGN EXISTING ONE TO VARIABLE
    '    strDynamicSheet = ActiveSheet.Name    'ASSIGN DYNAMIC SHEET
    '    Sheets(strPivsheet).Select    'GO BACK TO PIVOT DATA SHEET
    '
    '    'CREAT PIVOT
    '    ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:= _
         '                                 "'" & ActiveSheet.Name & "'!R1C1:R" & lngR & "C" & intC, TableDestination:="'" & strDynamicSheet & "'!R1C1", TableName:="PivotTable1"
    '
    '    'ADD CENTER DATA FIELD!!! IMPORTANT - DO THIS FIRST FOR PIVOT ROW AND COLUMN FIELDS TO WORK CORRECTLY - PASSED VARIABLE USED FOR PIVOT COLUMN
    '    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
         '                                                        "PivotTable1").PivotFields(strPivCol1), "Count of" & strPivCol1, xlCount
    '
    '    'ADD ROW FIELD (LEFT HAND VERTICAL PART OF PIVOT TABLE) - PASSED VARIABLE USED FOR PIVOT ROW FIELD
    '    With ActiveSheet.PivotTables("PivotTable1").PivotFields(strPivCol1)
    '        .Orientation = xlRowField
    '        .Position = 1    'IMPORTANT ONLY IF MULTIPLE FIELDS ADDED
    '    End With
    '
    '    'ADD COLUMN FIELD (TOP HORIZONTAL PART OF PIVOT TABLE) - PASSED VARIABLE USED FOR PIVOT COLUMN FIELD
    '    With ActiveSheet.PivotTables("PivotTable1").PivotFields(strPivCol2)
    '        .Orientation = xlColumnField
    '        .Position = 1    'IMPORTANT ONLY IF MULTIPLE FIELDS ADDED
    '    End With


End Sub

Sub ColorandBold()
'USE-COLOR AND BOLD TEXT STRINGS WITHIN TEXT EXCEL VBA
'BROUGHT TO YOU BY WWW.PROGRAMMINGLIBRARY.COM
'CREATED BY MARK SLOBODA


'************************* DEC VARS *******************************
    Dim myCell As Range
    Dim myRng As Range
    Dim FirstAddress As String
    Dim iCtr As Long
    Dim letCtr As Long
    Dim startrow As Long    'BEGINNING OF RANGE
    Dim endrow As Long    ' END OF RANGE
    Dim startcolumn As Integer    'BEGINNING COLUMN
    Dim endcolumn As Integer    'END COLUMN


    '************************* SET VALUES*****************************
    'DUMMY VALUES - COULD BE PASSED
    startrow = 2
    endrow = 5
    startcolumn = 1
    endcolumn = 2


    'SET UP RANGE YOU ARE COLORING AND BOLDING -YOU COULD MODIFY TO PASS VALUE TO
    Set myRng = Range(Cells(startrow, startcolumn), Cells(endrow, endcolumn))


    'SET UP ARRAY WITH WORDS YOU WANT TO COLOR AND BOLD - YOU COULD PUSH VALUES FROM A LISTBOX TO THIS ARRAY
    myWords = Array("dog", "cat", "hamster")


    'BEGIN MASTER LOOP---------------------------------------
    For iCtr = LBound(myWords) To UBound(myWords)
        'ERROR FOUND-BYPASS
        On Error Resume Next
        With myRng
            Set myCell = .Find(What:=myWords(iCtr), After:=.Cells(1), _
                               LookIn:=xlValues, LookAt:=xlPart, _
                               SearchOrder:=xlByRows, _
                               SearchDirection:=xlNext, _
                               MatchCase:=False)
            'LOGIC CHECK
            If Not myCell Is Nothing Then
                FirstAddress = myCell.Address


                Do
                    For letCtr = 1 To Len(myCell.Value)
                        If StrComp(Mid(myCell.Value, letCtr, _
                                       Len(myWords(iCtr))), _
                                       myWords(iCtr), vbTextCompare) = 0 Then
                            myCell.Characters(Start:=letCtr, _
                                              Length:=Len(myWords(iCtr))) _
                                              .Font.ColorIndex = 5
                        End If


                    Next letCtr


                    For letCtr = 1 To Len(myCell.Value)
                        If StrComp(Mid(myCell.Value, letCtr, _
                                       Len(myWords(iCtr))), _
                                       myWords(iCtr), vbTextCompare) = 0 Then
                            myCell.Characters(Start:=letCtr, _
                                              Length:=Len(myWords(iCtr))) _
                                              .Font.FontStyle = "Bold"
                        End If
                    Next letCtr


                    'GET NEXT ADDRESS
                    Set myCell = .FindNext(myCell)


                Loop While Not myCell Is Nothing _
                     And myCell.Address <> FirstAddress
            End If
        End With
    Next iCtr
End Sub

Sub Dynafont(fsize As Integer, ftype As String, fzoom As Integer)
'Created by Mark Sloboda but as Always Open source, use as you like


'USE-SET USUABILITY CONTROLS
'NOTES - BE SURE TO CHANGE NAME OF FORM TO CORRECT NAME


'DEC VARS
    Dim ctl As Control
    Dim nameof As String
    'fsize = font size
    'ftype = font family type i.e. Tahoma, Verdana, Arial
    'fzoom = desired zoom level of form


    On Error Resume Next    'AVOID ERRORS OF CONTROLS THAT PROPERTIES CAN'T BE CHANGED - 


    'BEGIN CODE
    For Each ctl In frmWhatever.Controls  'DON'T FORGET TO CHANGE FOR NAME TO YOURS!!!
        If IsNull(ctl.Name) = True Then
            GoTo bypass
        Else
            Controls(ctl.Name).Font.Size = fsize
            Controls(ctl.Name).Font.Name = ftype
            GoTo bypass
        End If
bypass:
    Next ctl
    
    frmWhatever.Zoom = fzoom  'INSERT APPROPRIATE FORM NAME HERE


End Sub