Posts by Richie(UK)

Richie(UK) · Jul 25th 2012

Re: Reduce running time of macro - help appreciated!

Hi Eric and welcome to the forum (and congratulations on a well-presented first post!).

You have already identified the common speed-up measures (Screenupdating and Calculation).

The code could be tidied here and there by assigning some variables to the various objects and using With statements but I'm not sure how much that will help. Have you tried stepping through the code (F8) to try to identify any obvious bottlenecks in execution time? Also, just to give us some context, what size are the worksheets that you are working with (how many rows and columns are currently used)?

Richie(UK) · Jul 25th 2012

Re: Status Bar

Where is the variable glb_origCalculationMode declared? How/when is it given a value?

If you want a percentage figure you will need to know how many files are being processed. I assume that you have a function called GetFileList that is used to populate the fileList Variant variable. Have a look at the Ubound property and use that in combination with my original post (#2) to see if you can figure it out.

Richie(UK) · Jul 24th 2012

Re: Look at cell value and split file

Hi,

I goofed on the Find part, that's why it gave the error. Try the following replacement:

Code

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).Cut
            With wbkNew
                .ActiveSheet.Paste
                .SaveAs wbk.Name & "1"
                .Close
            End With
            .Range("A1:V" & rngFound.Row).EntireRow.Delete
            wbk.SaveAs wbk.Name & "2"
            wbk.Close
        End If
         'if date found proceed
    End With
     
End Sub

Display More

Richie(UK) · Jul 24th 2012

Re: Status Bar

Hi,

You need to actually tell the status bar to display the message. Add the following line after the part where the StatusBarMsg variable is updated.

Code

Application.StatusBar = StatusBarMsg

Richie(UK) · Jul 24th 2012

Re: Look at cell value and split file

OK, a slight change of approach is needed I think - otherwise we will be adding workbooks into the directory that is being processed and that could cause problems. The amended version below uses a function, courtesy of JWalk, to get an array of file names and then process this rather than looping through the directory.

Code

Sub Main()
    Const strPath As String = "C:\Documents and Settings\Richie\My Documents\Excel\Tests\"
     'define appropriate directory here
    Dim x As Variant, i As Integer
     
    Application.ScreenUpdating = False
     'speed-up process by not displaying
     
    x = GetFileList(strPath)
    
    Select Case IsArray(x)
        Case True 'files found
            For i = LBound(x) To UBound(x)
                Call Subord(strPath & x(i))
                'Kill strPath & x(i)
            Next i
        Case False 'no files found
            MsgBox "No matching files"
    End Select
    'loop through all of the files, call a sub to do our processing, delete the original file
      
    Application.ScreenUpdating = True
     'reset display
     
End Sub
 
Function GetFileList(FileSpec As String) As Variant
'JWalk function
'   Returns an array of filenames that match FileSpec
'   If no matching files are found, it returns False


    Dim FileArray() As Variant
    Dim FileCount As Integer
    Dim FileName As String
    
    On Error GoTo NoFilesFound


    FileCount = 0
    FileName = Dir(FileSpec)
    If FileName = "" Then GoTo NoFilesFound
    
'   Loop until no more matching files are found
    Do While FileName <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileArray(1 To FileCount)
        FileArray(FileCount) = FileName
        FileName = Dir()
    Loop
    GetFileList = FileArray
    Exit Function


'   Error handler
NoFilesFound:
    GetFileList = False
End Function


Sub Subord(strFullName As String)
    Const strDate As String = "30/12/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
        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).Cut
            With wbkNew
                .ActiveSheet.Paste
                .SaveAs wbk.Name & "1"
                .Close
            End With
            .Range("A1:V" & rngFound.Row).EntireRow.Delete
            wbk.SaveAs wbk.Name & "2"
        End If
         'if date found proceed
    End With
     
End Sub

Display More

Richie(UK) · Jul 23rd 2012

Re: Macro keeps gettin error 13!!

Please remember to use code tags when posting code to the forum - I've done it for you this time.

Richie(UK) · Jul 23rd 2012

Re: Look at cell value and split file

Hi,

OK, first draft suggestion below. Please note that I don't have time to test this at the moment. Given that the code includes file deletion I strongly suggest that you work with a dummy directory and dummy workbooks until the code is working as intended - please exercise care. (I have commented out the deletion line in the code below - probably best to leave it like that until everything else is working as intended).

Code

Sub Main()
    Const strPath As String = "C:\Documents and Settings\Richie\My Documents\Excel\Tests\"
    'define appropriate directory here
    Dim strFile As String


    Application.ScreenUpdating = False
    'speed-up process by not displaying
    
    strFile = Dir(strPath & "*.xls")
    Do While strFile <> ""
        Call Subord(strPath & strFile)
        'Kill strPath & strFile
        strFile = Dir()
    Loop
    'loop through all of the files, call a sub to do our processing, delete the original file
    
    Application.ScreenUpdating = True
    'reset display
    
End Sub


Sub Subord(strFullName As String)
    Const strDate As String = "30/12/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
        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).Cut
            With wbkNew
                .ActiveSheet.Paste
                .SaveAs wbk.Name & "1"
                .Close
            End With
            .Range("A1:V" & rngFound.Row).EntireRow.Delete
            wbk.SaveAs wbk.Name & "2"
        End If
        'if date found proceed
    End With
    
End Sub

Display More

Richie(UK) · Jul 22nd 2012

Re: Status Bar

Hi and welcome to the firum.

You could amend something like this to suit your purposes.

Code

Sub SBProgInd()
    Dim Count As Long, Iterations As Integer, progress As Integer
    
    Iterations = 10000
    
    For Count = 1 To Iterations
        Sheet1.Range("A20").Value = Count
        progress = Count * 100 / Iterations
        Application.StatusBar = progress & "% complete"
    Next Count


End Sub

Display More

Richie(UK) · Jul 22nd 2012

Re: Look at cell value and split file

Hi and welcome to the forum.

Is column A in date order or would the worksheet need to be sorted first?
Is there a set number of columns that is used?
Are the files to be saved in the same folder as the original files?

Richie(UK) · Jul 22nd 2012

Re: Using sendkeys and loop to download files

Hi,

How about a slight re-hash of the last part (lCount as a Long variable):

Code

Set inputCollection = ieDoc.getElementsByTagName("download")
     
    lCount = 0
    For Each inputElement In inputCollection
        lCount = lCount + 1
        If inputElement.getAttribute("value") = "Download" And lCount = 4 Then
            inputElement.Click
            Exit For
        End If
    Next inputElement

If that doesn't work could you persuade your IT guys to set-up an example page for us to work with - identical to the one that you are accessing but with any sensitive data replaced by dummy text files?

Richie(UK) · Jul 19th 2012

Re: Need to automate goal seek with VBA

Hi and welcome to the forum.

You may need to tinker with this as I couldn't immediately see how you planned to increment the capex but it should help get you started.

Code

Sub Alice()
    Dim wsCash As Worksheet
    Dim rngIRR As Range
    Dim lCount As Long
    Const lFCInc As Long = 50000
    
    Set wsCash = ThisWorkbook.Worksheets("Cashflows")
    Set rngIRR = wsCash.Range("D4")
    
    For lCount = 1 To 12
        rngIRR.GoalSeek Goal:=Range("req_rate_of_return").Value, ChangingCell:=Range("capacity_fee")
        Range("cap_fee_" & lCount).Value = Range("capacity_fee").Value
        Range("capex_" & lCount).Value = Range("total_capex").Value
        Range("fixed_capex").Value = Range("fixed_capex").Value + lFCInc
        'or however you want to increment capex
    Next lCount
    
End Sub

Display More

Richie(UK) · Jul 18th 2012

Re: Autofilter Block Of Data From Activecells Offset

I thought it a little odd that you only wanted to sort column E - must have misread that bit. Try removing the .Columns(4) part from the Sort line - that should then sort the whole rngAF range.

Richie(UK) · Jul 18th 2012

Re: Opening files using cell values

Just checking to make sure that you were paying attention - well spotted

Richie(UK) · Jul 17th 2012

Re: Opening files using cell values

Hi and welcome to the forum.

Caveats: Not tested and no error-checking. Should get you started though.

Code

Sub test()
    Dim rngFiles As Range, rngCell As Range
    Dim lRow As Long
    Dim wsData As Range
    Dim wbkCount As Workbook
    
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
    
    With wsData
        lRow = .Cells(.Rows.Count, "G").End(xlUp).Row
        Set rngFiles = .Range("G1:G" & lRow)
    End With
    'establish the range containing the filenames
    
    Application.ScreenUpdating = False
    For Each rngCell In rngFiles
        Set wbkCount = Workbooks.Open(rngCell.Value)
        rngCell.Offset(7, -2).Value = wbkCount.Worksheets.Count
        wbkCount.Close savechanges:=False
    Next rngCell
    Application.ScreenUpdating = True
    'open each workbook and record count of sheets
    
End Sub

Display More

Richie(UK) · Jul 17th 2012

Re: Loop to run calculation on every row with data

Hi and welcome to the forum.

Wouldn't it be simpler to write functions for each of the calculations to be undertaken (TPO, PMVval, and N)? You can then just apply the function to as many rows as needed, as you would for a standard Excel function.

Richie(UK) · Jul 16th 2012

Re: Autofilter Block Of Data From Activecells Offset

Sorry, missed that bit. Doh!

Code

Sub OrToePhilTar()
    Dim rngAF As Range
     
    Set rngAF = Range(ActiveCell.Offset(-1, 1), ActiveCell.Offset(2, 4))
    rngAF.AutoFilter
    rngAF.Columns(4).Sort Key1:=ActiveCell.Offset(0, 4), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        
End Sub

Richie(UK) · Jul 16th 2012

Re: How to find minimum value in every row VBA

Something like this?

Code

Sub test()
    Dim lRowEnd As Long
    
    With Worksheets("Sheet1")
        lRowEnd = .Cells(.Rows.Count, "O").End(xlUp).Row
        .Range("P4").FormulaR1C1 = "=MIN(RC[-3]:RC[-1])"
        .Range("P4").AutoFill Destination:=Range("P4:P" & lRowEnd)
    End With
    
End Sub

Richie(UK) · Jul 16th 2012

Re: Autofilter Block Of Data From Activecells Offset

Hi,

Something like this?

Code

Sub OrToePhilTar()
    Dim rngAF As Range
    
    Set rngAF = Range(ActiveCell.Offset(-1, 1), ActiveCell.Offset(2, 4))
    rngAF.AutoFilter
    
End Sub

Richie(UK) · Jul 16th 2012

Re: How to find minimum value in every row VBA

Hi and welcome to the forum.
Any particular reason for wanting a VBA approach? If you really want the VBA approach how about using the Macro Recorder while you type in the appropriate formula? You can then tidy it up to suit your needs.

Richie(UK) · Jul 13th 2012

Re: Loop through visible rows only.

Hi,

The SpecialCells method is indeed the way to go here. Specifically you want to make use of the xlCellTypeVisible type. This, as the name suggests, applies to all visible cells (ie it will exclude those that do not fit the filter criteria). So, we apply our filter and then set a range that is equal to the filtered range as modified by the SpecialCells method. We can then loop through this non-contiguous range if we wish. See below for a simple example.

Code

Sub Mumps()
    Dim rngAF As Range, rngCell As Range


    With ActiveSheet
        If Not .AutoFilterMode Then
            MsgBox "AutoFilter must be On !"
            Exit Sub
        End If
        If Not .FilterMode Then
            MsgBox "Filters must be applied!"
            Exit Sub
        End If
        Set rngAF = .AutoFilter.Range.SpecialCells(xlCellTypeVisible)
    End With
    
    For Each rngCell In rngAF
        MsgBox rngCell.Address
        'just for illustration
    Next rngCell
    
End Sub

Display More