Posts by Richie(UK)

Sub To_Err_Is_Human()
    Dim rngCell As Range
    
    On Error GoTo ErrHandler
TheStart:
    MsgBox Err.Number
    Set rngCell = Cells(0, 0)
    
Exit Sub
ErrHandler:
    MsgBox Err.Number
    GoTo TheStart
End Sub


Sub To_Err_Is_Human2()
    Dim rngCell As Range
    
    On Error GoTo ErrHandler
TheStart:
    MsgBox Err.Number
    Set rngCell = Cells(0, 0)
    
Exit Sub
ErrHandler:
    MsgBox Err.Number
    Resume TheStart
End Sub

Sub Find_Call()
    Dim wsMain As Worksheet, wsBackup As Worksheet
    Dim rngCell As Range, strFirst As String
    
    Set wsMain = ThisWorkbook.Worksheets("main")
    Set wsBackup = ThisWorkbook.Worksheets("backup")
    'the worksheets
    
    With wsMain.Cells
        Set rngCell = .Find(what:="call", LookIn:=xlValues)
        'look for target text
        If Not rngCell Is Nothing Then
            'if found, proceed with copying
            strFirst = rngCell.Address
            Do
                rngCell.EntireRow.Copy _
                    wsBackup.Range("A" & wsBackup.Cells(wsBackup.Rows.Count, "A").End(xlUp).Row + 1)
                Set rngCell = .FindNext(rngCell)
            Loop While Not rngCell Is Nothing And rngCell.Address <> strFirst
        End If
    End With


End Sub

Sub c4000lc()
    Dim c As Range, rngData As Range
    Dim wsData As Worksheet, wsPrint As Worksheet
    
    Set wsData = ThisWorkbook.Worksheets("4numbers")
    Set wsPrint = ThisWorkbook.Worksheets("C4000LC")
    'the worksheets we are using
    
    With wsData
        Set rngData = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
        'MsgBox rngData.Address
    End With
    'an alternative to UsedRange
    
    For Each c In rngData
        c.Copy Destination:=wsPrint.Range("h30")
        wsPrint.PrintOut Copies:=1, ActivePrinter:="GlobalMark Color & Cut (Copy 2) on COM1:"
    Next
    'loop through, as before
    
End Sub

Sub test()


    On Error Resume Next
    Err.Clear
    
    Err.Raise (1004)
    
    If Err.Number = 1004 Then
      MsgBox "Oops " & Err & " " & Error(Err)
    End If


End Sub

'******************************************************************
'Using WinRar within Excel
'Syntax
'
'    RAR <command>  [ -<switches> ]  <archive>  [ <@listfiles...> ]
'        [ <files...> ] [ <path_to_extract\> ]
'******************************************************************


'*************
' Adding files
'*************


Sub WinRarIt()


Dim WinRarPath As String    'WinRar.exe location
Dim RarIt As String         'Command line instruction
Dim SourceDir As String     'The source directory
Dim SourceFile As String    'The source file
Dim Source As String        'The combined Rar from path(s)(FROM)
Dim DestDir As String       'The Rarped file directory
Dim DestRarName As String   'The Rarped file
Dim Dest As String          'The combined Rar to path (TO)


'*** Check installation of WinRar ***
WinRarPath = "C:\Program Files\WinRar\"
If Dir(WinRarPath, vbDirectory) = "" Then
    MsgBox "WinRar is not installed in the default directory." _
    & Chr$(13) & "Archiving of files will not be possible."
    Exit Sub
End If


'*** Set the source details ***
SourceDir = ThisWorkbook.Path & "\"
SourceFile = "This has spaces.xls"
Source = SourceDir & "\" & SourceFile
'If source name has one or more spaces surround it with ""
If InStr(1, Source, " ", vbTextCompare) <> 0 Then Source = Chr(34) & Source & Chr(34)


'*** Set the destination details
DestDir = "C:\Rarped Excel Files"
'check that it exists
If Dir(DestDir, vbDirectory) = "" Then MkDir DestDir
DestRarName = "Test.Rar"
Dest = DestDir & "\" & DestRarName
If InStr(1, Dest, " ", vbTextCompare) <> 0 Then Dest = Chr(34) & Dest & Chr(34)


'*** Do the Rarping ***
RarIt = Shell(WinRarPath & "WinRar.exe a " & Dest & " " & Source, vbNormalFocus)


End Sub


'*****************
' Extracting files
'*****************


Sub UnWinRarIt()


Dim WinRarPath As String        'WinRar.exe location
Dim RarIt As String             'Command line instruction
Dim SourceDir As String         'The source directory
Dim SourceRarFile As String     'The source file
Dim Source As String            'The combined Rar from path(s)(FROM)
Dim Dest As String              'The combined unRar to path (TO)


WinRarPath = "C:\Program Files\WinRar\"
If Dir(WinRarPath, vbDirectory) = "" Then
    MsgBox "WinRar is not installed in the default directory." _
    & Chr$(13) & "Archiving of files will not be possible."
    Exit Sub
End If


SourceDir = "C:\Rarped Excel Files"
SourceRarFile = "Test.Rar"
Source = SourceDir & "\" & SourceRarFile
If InStr(1, Source, " ", vbTextCompare) <> 0 Then Source = Chr(34) & Source & Chr(34)


Dest = "C:\UnRarped Excel Files\"
If Dir(Dest, vbDirectory) = "" Then MkDir Dest
If InStr(1, Dest, " ", vbTextCompare) <> 0 Then Dest = Chr(34) & Dest & Chr(34)


RarIt = Shell _
    (WinRarPath & "WinRar.exe e " & Source & " " & Dest, vbNormalFocus)


End Sub

Sub test_ws_add()
    Dim rngRaw As Range, rngCell As Range
    Dim wsRaw As Worksheet
    Dim wsNew As Worksheet
     
    Set wsRaw = ActiveWorkbook.Worksheets("Counts")
    Set rngRaw = wsRaw.Range("A2:A" & wsRaw.Cells(wsRaw.Rows.Count, "A").End(xlUp).Row)
    'set range of unique IDs
    
    For Each rngCell In rngRaw
        If Not SheetExists(rngCell.Value) Then
            Set wsNew = Worksheets.Add
            wsNew.Name = rngCell.Value
        End If
    Next rngCell
    'loop through each unique ID and add sheet if doesn't already exist
    
End Sub
 
Function SheetExists(strWSname As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(strWSname)
    On Error GoTo 0
    If Not ws Is Nothing Then SheetExists = True
End Function

Sub Main()
    Dim rngToTest As Range, rngUnique As Range, rngCell As Range
    Dim wsNew As Worksheet
    
    Application.ScreenUpdating = False
    
    With Worksheets("Sheet1")
        Rows("1:1").Insert
        .Range("A1").Value = "Dummy header"
        'add header rows for Advanced Filter
        Set rngToTest = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
        rngToTest.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("G1"), Unique:=True
        'copy the unique entries to another range (amend "G1" to suit)
        Rows("1:1").Delete
        'remove header rows
        Set rngUnique = .Range("G1:G" & .Cells(Rows.Count, "G").End(xlUp).Row)
        'establish a reference to the unique range and the range at its right
        For Each rngCell In rngUnique
            If Not SheetExists(rngCell.Value) Then
                Set wsNew = Worksheets.Add
                wsNew.Name = rngCell.Value
                'do stuff
            End If
            'add new sheet if not already present
        Next rngCell
        'loop through the unique range
    End With
    
    Application.ScreenUpdating = True


End Sub


Function SheetExists(strWSname As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(strWSname)
    On Error GoTo 0
    If Not ws Is Nothing Then SheetExists = True
End Function

Sub test_ws_add()
    Dim strWSname As String
    Dim wsNew As Worksheet
    
    strWSname = "Sheet4"
    If Not SheetExists(strWSname) Then
        Set wsNew = Worksheets.Add
        wsNew.Name = strWSname
    End If
    
End Sub


Function SheetExists(strWSname As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(strWSname)
    On Error GoTo 0
    If Not ws Is Nothing Then SheetExists = True
End Function

Sub ByeBye()
    Const strDir As String = "C:\Documents and Settings\Richie\My Documents\Excel\Tests\"
    'the path to the directory containing the files
    Dim wsFiles As Worksheet
    Dim rngFiles As Range, rngCell As Range
    
    Set wsFiles = ThisWorkbook.Worksheets("Sheet1")
    Set rngFiles = wsFiles.Range("A1:A250")
    'the worksheet and range contaning the list of files
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    'speed-up process
    
    For Each rngCell In rngFiles
        Kill strpath & rngCell.Value
    Next rngCell
    'loop through the file names
    
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    'reset
    
End Sub

Sub Subord(strFullName As String)
    Const strDate As String = "12/30/2004"
    Dim wbk As Workbook, rngFound As Range, wbkNew As Workbook
     
    Set wbk = Workbooks.Open(strFullName)
     'open the workbook to work with
    
    With wbk.ActiveSheet.Cells
        Set rngFound = .Find(what:=DateValue(strDate), LookIn:=xlFormulas)
         'search for date
        If Not rngFound Is Nothing Then
            Set wbkNew = Workbooks.Add
            .Range("A1:V" & rngFound.Row).Copy
            With wbkNew
                .ActiveSheet.Paste
                .SaveAs wbk.Path & Application.PathSeparator & Left(wbk.Name, Len(wbk.Name) - 4) & "1" & ".xls"
                .Close
            End With
            .Range("A2:V" & rngFound.Row).EntireRow.Delete
            .SaveAs wbk.Path & Application.PathSeparator & Left(wbk.Name, Len(wbk.Name) - 4) & "2" & ".xls"
        End If
         'if date found proceed
    End With
     
End Sub