BreadCrumbs: Excel

Excel

From Luke Jackson

(Difference between revisions)
Jump to: navigation, search
Revision as of 01:17, 10 December 2014 (edit)
Ljackson (Talk | contribs)
(→Color)
← Previous diff		 Revision as of 19:17, 14 December 2014 (edit)
Ljackson (Talk | contribs)
(→Color)
Next diff →
Line 285: Line 285:
</pre> </pre>
 +
 +== Manipulate Cells with SQL based Macro (Append/Merge/Combine adjacent columns one after the other) ==
 +
 +<pre>
 +Sub doSQL()
 +
 +
 + Dim strCon As String
 + Dim oneSQL As String
 +
 + ' refer to 'microsoft activex data objects library'
 + Dim cn As Object
 + Dim rs As Object
 +
 +
 + Set cn = CreateObject("ADODB.Connection")
 + Set rs = CreateObject("ADODB.Recordset")
 +
 + strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
 + "Data Source='" & ThisWorkbook.FullName & "';" & _
 + "Extended Properties='Excel 12.0;HDR=No;IMEX=1';" ' HDR=No means no headers (field names)
 +
 +
 + cn.Open strCon ' open connection
 +
 +'-------------------------------------------------------------------------------
 +
 + ' F1, F2, F3 are the default fieldnames when no headers are included with data
 +
 +
 + oneSQL = "SELECT F3 FROM [Sheet1$B:D] where F3 not like '' union all " & _
 + "SELECT F1 FROM [Sheet1$B:D] where F1 not like '' union all " & _
 + "SELECT F2 FROM [Sheet1$B:D] where F2 not like ''; "
 +
 + rs.Open oneSQL, cn ' get recordset
 +
 +
 + Sheets("Sheet1").Range("A:A").ClearContents
 +
 + Sheets("Sheet1").Range("A1").CopyFromRecordset rs ' copy recordset to worksheet
 +
 +'-------------------------------------------------------------------------------
 +
 + rs.Close
 + cn.Close
 +
 + Set rs = Nothing
 + Set cn = Nothing
 +
 +
 +End Sub
 +</pre>
== Color == == Color ==

Revision as of 19:17, 14 December 2014

Contents

Windows XP

Excel 2007

Data -> From Other Sources ->

Dynamic Chart Titles From Pivot Table (Date Range) 

=IF(DAY(MIN(Summary!$B$6:$B$20))=DAY(MAX(Summary!$B$6:$B$20)),CONCATENATE("CW ",WEEKNUM(MIN(Summary!$B$6:$B$20),1)," - ",TEXT(MIN(Summary!$B$6:$B$20),"mmmm"), ", ",DAY(MIN(Summary!$B$6:$B$20))&IF(OR(DAY(MIN(Summary!$B$6:$B$20))={1,2,3,21,22,23,31}),CHOOSE(1*RIGHT(DAY(MIN(Summary!$B$6:$B$20)),1),"st","nd ","rd"),"th")),CONCATENATE("CW ",WEEKNUM(MIN(Summary!$B$6:$B$20),1)," - ",TEXT(MIN(Summary!$B$6:$B$20),"mmmm"), ", ",DAY(MIN(Summary!$B$6:$B$20))&IF(OR(DAY(MIN(Summary!$B$6:$B$20))={1,2,3,21,22,23,31}),CHOOSE(1*RIGHT(DAY(MIN(Summary!$B$6:$B$20)),1),"st","nd ","rd"),"th")," - ",CONCATENATE("CW ",WEEKNUM(MAX(Summary!$B$6:$B$20),1)," - ",TEXT(MAX(Summary!$B$6:$B$20),"mmmm"), ", ",DAY(MAX(Summary!$B$6:$B$20))&IF(OR(DAY(MAX(Summary!$B$6:$B$20))={1,2,3,21,22,23,31}),CHOOSE(1*RIGHT(DAY(MAX(Summary!$B$6:$B$20)),1),"st","nd ","rd"),"th"))))

Week Number 

=CONCATENATE("Cal Week: ", (1+INT((#REF!-(DATE(YEAR(#REF!),1,2)-WEEKDAY(DATE(YEAR(#REF!),1,0))))/7)))

=WEEKNUM(TEXT(E2, "mmmm dd, yyyy"), 2)

Count Cells when not blank 

=COUNTIF(D2:G2,"<>"&"")

Concatenate Vlookup Values When Source is not blank 

=CONCATENATE(IF(D17 <> "",(VLOOKUP(D17,Printtypes!$A$1:$B$19, 2,FALSE)),""),IF(E17 <> "",(", " & VLOOKUP(E17,Printtypes!$A$1:$B$19, 2,FALSE)),""),IF(F17 <> "",(", " & VLOOKUP(F17,Printtypes!$A$1:$B$19, 2,FALSE)),""),IF(G17 <> "",(", " & VLOOKUP(G17,Printtypes!$A$1:$B$19, 2,FALSE)),""))

CountIf with Subtotal (Respects Hidden/Filtered Cells 

=SUMPRODUCT(SUBTOTAL(3,OFFSET(B1:B51,ROW(B1:B51)-ROW(B1),0,1)),--(B1:B51="Inactive"))

Count Unique Names / Numbers

The entire formula is as follows (replace C3:C25 with the range of data you want the formula to check) 

=SUM(IF(FREQUENCY(IF(LEN(C3:C25)>0,MATCH(C3:C25,C3:C25,0),""), IF(LEN(C3:C25)>0,MATCH(C3:C25,C3:C25,0),""))>0,1))

If you just want to count unique numbers, and not text, use the following formula instead: 

=SUM(IF(FREQUENCY(C3:C25, C3:C25)>0,1))

Split string by occurrence of character

Return the portion of string from the second occurrence of character: 

=RIGHT($E2;LEN($E2) - FIND("-";$E2;FIND("-";$E2)+1))

Return the portion of string until the first occurrence of character: 

=LEFT($E2;FIND("-";$E2)-1)

Conditional Formating "At Change In Value" 

Private Sub Worksheet_Change(ByVal Target As Range)

  Dim C As Variant
  Dim Clast As Variant
  Dim CI As Integer
  Dim ColS As Variant
  Dim ColE As Variant
  Dim FirstRow As Long
  Dim LastRow As Long
  Dim Rng As Range
  Dim Wks As Worksheet
  Dim Color As Boolean
  Dim Total As Long
  
  If Target.Row > 0 Then
  
        ColS = "A"
        ColE = "L"
        FirstRow = 2   'Assumes header row is row 1
        Set Wks = Worksheets("Scoreboard")
        'LastRow = Wks.Cells(Rows.Count, ColS).End(xlUp).Row
        LastRow = Target.Row
        
        LastRow = IIf(LastRow < FirstRow, FirstRow, LastRow)
    
      Set Rng = Wks.Range(Cells(FirstRow, ColS), Cells(LastRow, ColS))
        For Each C In Rng
          If IsDate(C) Then
            
            If Clast = "" Then
                CI = 50
                Clast = C
                'MsgBox "Start " & C & " - " & Clast
            ElseIf C <> Clast And Color = False Then
                CI = xlColorIndexNone
                Color = True
                'MsgBox "CF CNE " & C & "<>" & Clast
                Clast = C
            ElseIf C <> Clast And Color = True Then
                CI = 50
                Color = False
                'MsgBox "CT CNE " & C & "<>" & Clast
                Clast = C
            ElseIf C = Clast And Color = False Then
                CI = 50
                'MsgBox "CF CE " & C & "=" & Clast
                Clast = C
            ElseIf C = Clast And Color = True Then
                CI = xlColorIndexNone
                'MsgBox "CT CE " & C & "=" & Clast
                Clast = C
            Else
                CI = xlColorIndexNone
                MsgBox "Else " & C
            End If
            
            If CI > 0 Then
                With Range(Cells(C.Row, ColS), Cells(C.Row, ColE)).Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .ThemeColor = xlThemeColorAccent3
                    .TintAndShade = 0.599993896298105
                    .PatternTintAndShade = 0
                End With
            Else
                With Range(Cells(C.Row, ColS), Cells(C.Row, ColE)).Interior
                    .Pattern = xlNone
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With
            End If
            
          End If
          
          Total = Total + 1
          
        Next C
        
        'MsgBox Total
    End If
        
End Sub

Function 

=IF(INDIRECT(ADDRESS(ROW(),1,3))<>INDIRECT(ADDRESS((ROW()-1),1,3)),1,0)

Date Filters Not Available for Pivot Table / Chart

Date Filters are not supported in Excel 2003 compatibility mode.

Re-save document in Excel 2007 format and the options will no longer be greyed out.

Dynamic Graph/Chart Title 

="Operator Summary - " & TEXT(MIN(Summary!$B$6:$B$20),"ddd, mmm dd, yyyy") & " to " & TEXT(MAX(Summary!$B$6:$B$20),"ddd, mmm dd, yyyy")

Mac OS X

File Not Found

When starting Microsoft Excel 2004 for Mac OS X you may get the error "File Not Found".

First place to check is the Excel Startup folder: 

ljackson 14:46:50 ~/Library/Preferences> cd /Applications/Microsoft\ Office\ 2004/Office/Startup/
ljackson 14:47:33 /Applications/Microsoft Office 2004/Office/Startup> ll
drwxrwxr-x   4 ljackson  admin  136B May  3 14:39 Excel
drwxrwxr-x   2 ljackson  admin  68B Apr  8  2004 PowerPoint
drwxrwxr-x   2 ljackson  admin  68B Apr  8  2004 Word
ljackson 14:47:33 /Applications/Microsoft Office 2004/Office/Startup> cd Excel/
ljackson 14:47:37 /Applications/Microsoft Office 2004/Office/Startup/Excel> ll
total 96
-rw-r--r--   1 ljackson  admin    25K May  3 14:15 8DAE9700
-rw-r--r--   1 ljackson  admin    16K May  3 14:39 Personal Macro Workbook

In my case the alphanumerical file was generated when Excel crashed. So I will delete it: 

ljackson 14:47:38 /Applications/Microsoft Office 2004/Office/Startup/Excel> rm -f 8DAE9700 
ljackson 14:47:53 /Applications/Microsoft Office 2004/Office/Startup/Excel> ll
total 40
-rw-r--r--   1 ljackson  admin    16K May  3 14:39 Personal Macro Workbook

Now I don't get the anoying error "File Not Found" every time I launch Excel.

VBA Macros 

Sub RangeDateFix()
    Dim ndate As String
    'ActiveCell.CurrentRegion.Cells.Select
    For Each c In ActiveWindow.RangeSelection.Cells
        ndate = USdateEU(c.Value)
        c.Value = ndate
    Next
End Sub

Public Function USdateEU(ByVal tdate As String)
    Dim txt As String, ftxt As String, x As Variant, i As Long
    txt = tdate
    x = Split(txt, "/")
    'For i = 0 To UBound(x)
       'MsgBox x(i)
    'Next i
    ftxt = x(1) & "/" & x(0) & "/" & x(2)
    
    USdateEU = ftxt
    'MsgBox ftxt
End Function

Public Function Split(ByVal sInput As String, _
Optional ByVal sDelimiter As String, _
Optional ByVal nLimit As Long = -1, _
Optional ByVal bCompare As Integer = vbBinaryCompare _
) As Variant
  
Dim nCount As Long
Dim nPos As Long
Dim nDelimiterLength As Long
Dim nStart As Long
Dim sOutput() As String
  
If nLimit = 0 Then
    Split = Array()
Else
    nDelimiterLength = Len(sDelimiter)
    
    If nDelimiterLength = 0 Then
        Split = Array(sInput)
    Else
        nStart = 1
        nPos = InStr(nStart, sInput, sDelimiter, bCompare)
    
    Do While nPos
      
    ReDim Preserve sOutput(0 To nCount) As String
      
        If nCount + 1 = nLimit Then
            sOutput(nCount) = Mid(sInput, nStart)
            Exit Do
        Else
            sOutput(nCount) = Mid(sInput, nStart, nPos - nStart)
            nStart = nPos + nDelimiterLength
        End If
      
    nCount = nCount + 1
      
    nPos = InStr(nStart, sInput, sDelimiter, bCompare)
      
    Loop
      
    ReDim Preserve sOutput(0 To nCount) As String
      
    sOutput(nCount) = Mid(sInput, nStart)
      
    Split = sOutput
      
    End If
  
End If
  
End Function

Clear Old Pivot Table Labels 

Sub DeleteMissingItems2002All()
'prevents unused items in non-OLAP PivotTables
'pivot table tutorial by contextures.com
Dim pt As PivotTable
Dim ws As Worksheet
Dim pc As PivotCache

'change the settings
For Each ws In ActiveWorkbook.Worksheets
  For Each pt In ws.PivotTables
    pt.PivotCache.MissingItemsLimit = xlMissingItemsNone
  Next pt
Next ws

'refresh all the pivot caches
For Each pc In ActiveWorkbook.PivotCaches
  On Error Resume Next
  pc.Refresh
Next pc

End Sub


Manipulate Cells with SQL based Macro (Append/Merge/Combine adjacent columns one after the other) 

Sub doSQL()


    Dim strCon As String
    Dim oneSQL As String
    
    ' refer to 'microsoft activex data objects library'
    Dim cn As Object
    Dim rs As Object


    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source='" & ThisWorkbook.FullName & "';" & _
              "Extended Properties='Excel 12.0;HDR=No;IMEX=1';"    ' HDR=No  means no headers (field names)


    cn.Open strCon     ' open connection
    
'-------------------------------------------------------------------------------

    ' F1, F2, F3 are the default fieldnames when no headers are included with data    


    oneSQL = "SELECT F3 FROM [Sheet1$B:D] where F3 not like '' union all " & _
             "SELECT F1 FROM [Sheet1$B:D] where F1 not like '' union all " & _
             "SELECT F2 FROM [Sheet1$B:D] where F2 not like ''; "
    
    rs.Open oneSQL, cn      ' get recordset


    Sheets("Sheet1").Range("A:A").ClearContents

    Sheets("Sheet1").Range("A1").CopyFromRecordset rs     ' copy recordset to worksheet
    
'-------------------------------------------------------------------------------
    
    rs.Close
    cn.Close
    
    Set rs = Nothing
    Set cn = Nothing


End Sub

Color 

Function HEXCOL2RGB(ByVal HexColor As String) As String

    'The input at this point could be HexColor = "#00FF1F"

Dim Red As String
Dim Green As String
Dim Blue As String
Dim Color As String

Color = Replace(HexColor, "#", "")
    'Here HexColor = "00FF1F"

Red = Val("&H" & Mid(Color, 1, 2))
    'The red value is now the long version of "00"

Green = Val("&H" & Mid(Color, 3, 2))
    'The red value is now the long version of "FF"

Blue = Val("&H" & Mid(Color, 5, 2))
    'The red value is now the long version of "1F"

'HEXCOL2RGB = RGB(Red, Green, Blue)
HEXCOL2RGB = Red & "," & Green & "," & Blue
    'The output is an RGB value

End Function

Sub CvrtHex()
    Dim Cell As Range
    If TypeName(Selection) <> "Range" Then Exit Sub
    For Each Cell In Selection
        If Cell.Value < 0 Then
            'Debug.Print ""
        Else
            Debug.Print HEXCOL2RGB(Cell.Value)
            Cell.Next.Value = HEXCOL2RGB(Cell.Value)
        End If
    Next Cell
End Sub

Sub CvrtHex2()
    Dim Cell As Range
    Dim clrs As Variant
    If TypeName(Selection) <> "Range" Then Exit Sub
    For Each Cell In Selection
        If Cell.Value < 0 Then
            'Debug.Print ""
        Else
            clrs = Split(Cell.Value, ",")
            Debug.Print clrs(0) & " " & clrs(1) & " " & clrs(2)
            Cell.Next.Interior.Color = RGB(clrs(0), clrs(1), clrs(2))
            Cell.Next.Value = "R" & clrs(0) & " G" & clrs(1) & " B" & clrs(2)
            If clrs(0) < 200 And clrs(1) < 200 And clrs(2) < 200 Then
                Cell.Next.Font.Color = RGB(255, 255, 255)
                Debug.Print "White"
            Else
                Cell.Next.Font.Color = RGB(0, 0, 0)
            End If
        End If
    Next Cell
End Sub


Set Background Color of Cells to Adjacent Cell Value (RGB) 

Sub ColourCells()
Dim HowMany As Integer
On Error Resume Next
Application.DisplayAlerts = False
HowMany = Application.InputBox _
(Prompt:="Enter last row number.", Title:="To apply to how many rows?", Type:=1)
On Error GoTo 0
Application.DisplayAlerts = True
If HowMany = 0 Then
Exit Sub
Else
   Dim i As Integer
   For i = 2 To HowMany
      Cells(i, 6).Interior.Color = RGB(Cells(i, 2), Cells(i, 3), Cells(i, 4))
   Next i
End If
End Sub

See Also

Souces

See Also

Souces

Retrieved from "http://wiki.ljackson.us/Excel"
Personal tools