Do While Cells(x, "F").Value <> " " 5

Marisoleil · Sep 6, 2007

Hello All
Greetings Once Again,

I'm working with a 'do while' to keep looping and applying a procedure code until a blank row is found. This usually works nicely for me. In this case, however, there's a formula in the row: IF(this, then this, otherwise " ").
So there's a formula in the cell, but the value shown is 0.

I imagine that I should replace "Value" with something else in my 'Do While' command? Like something indicating value displayed in cell, not the formula typed in.

Any ideas or experience with this?

Cheers,
Marie

yogia · Sep 6, 2007

Hi Marie:

One way ... you may want to try something like ...

Code:

Do While Len(Trim([b]cellRef[/b])) > 0

this will quit LOOPing when the referenced cell CellRef is blank, is a formula blank, or a space character

I hope this helps.

Yogi Anand, D.Eng, P.E.
Energy Efficient Building Network LLC

http://www.energyefficientbuild.com

Marisoleil · Sep 7, 2007

Hi Yogi,
Thanks for code suggestion. Well, I tried it, but I am still gettting the same error. The error occurs at the line in my code "Workbooks.Open filename("pickme")" and this happens when the loop reaches the blank (displayed, yet containing a formula) cell. So, it seems as though it is still not stopping the loop.

Would you mind having a quick peek at my code below?

Thanks,
Any comments or suggestions welcome,
Marie

p.s. Contents of cells being looped through looks like following formula: =IF(AND('Sheet1'!B31<='Sheet1'!$K$11,'Sheet1'!B31>='Sheet1'!$K$8),CONCATENATE( 'Sheet1'!$A$4, 'Sheet1'!$B$11)," ")

Code:

Sub OpenURL()
        
Dim x%                                       
x = 18
Do While Len(Trim(Cells(x, "F"))) > 0
          
    Workbooks("Workbook1.xls").Sheets("Sheet1").Activate
    Cells(x, "F").Select
    Selection.Copy
    Application.CutCopyMode = False
    Dim pickme As String
    pickme = Cells(x, 6)
    Workbooks.Open Filename:=pickme
        
Dim StationName, StationID As String
Dim UpdateMonth As Variant
Dim UpdateYear As Integer

StationName = ActiveWorkbook.ActiveSheet.Cells(1, 2)
StationID = ActiveWorkbook.ActiveSheet.Cells(6, 2)
UpdateMonth = ActiveWorkbook.ActiveSheet.Cells(18, 3)
UpdateYear = ActiveWorkbook.ActiveSheet.Cells(18, 2)
Province = ActiveWorkbook.ActiveSheet.Cells(2, 2)


Dim MyStr As String
MyStr = Format(Date, "yyyy-mm-dd")

'Following code creates folder in data.in with today's date and Station Name, but only if folder doesn't already exist
Dim fso
Dim fol As String
fol = "S:\Project1\" & MyStr & " " & StationName
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fol) Then
    fso.CreateFolder (fol)
End If
ActiveWorkbook.SaveAs Filename:="S:\Project1\" & MyStr & " " & StationName & "\" & UpdateYear & "_" & UpdateMonth & "_" & StationName & "_" & StationID & ".xls", FileFormat:=xlNormal 
'ActiveWorkbook.Close SaveChanges = True
        
x = x + 1
Loop


End Sub

PHV · Sep 8, 2007

Perhaps this ?
Do While Len(Trim(Cells(x, "F")[!].Text[/!])) > 0

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

Crookshanks · Sep 10, 2007

Perhaps you should try the following (just to cover all posibilities):

Code:

do until len(trim(cells(x,"F").value) = 0 or _
         len(trim(cells(x,"F").text) = 0 or _
         len(trim(cells(x,"F").formula) 0
....
....
....
x=x+1
Loop

regards,

Marisoleil · Sep 10, 2007

Thanks for responses and suggestions. I'm still having trouble, and I have read over my original post and see that I erred in describing the situation in a tiny way: I don't have '0' in the cell at which I want the loop to stop, but it's simply a blank cell displayed.

Does this change things? What should I put instead of '0'? I have tried 'Empty' and "", but the code still does not seem to be exiting the loop successfully upon encountering the blank (displayed) cell. Is my formatting (indentations) problematic in my code? I thought this was just for readability, but now I am wondering if it presents problems for the loop?

Cheers,
Marie

Bong · Sep 10, 2007

Just for grins, try making your comparison >1 and see what happens.

_________________
Bob Rashkin

macropod · Sep 10, 2007

Hi Marisoleil,

The code:

Code:

Len(Trim(Cells(x, "F").Value)) > 0

will return 'False' for any cell that is empty, contains a string consisting of only soft spaces or a formula that returns such a string or a nul value. If there's a possibility that the cell has hard spaces, you could accommodate that via:

Code:

Len(Trim(Replace(Cells(x, "F").Value, Chr(160), Chr(32)))) > 0

Provided you've declared the cell addresses correctly and your formula really does return a blank, the above code will work. So, if you're still getting errors, what's the formula in the problem cell? Also, from my reading of the code, you're likely to have problems with:

Code:

pickme = Cells(x, 6)

I think this should be:

Code:

pickme = Cells(x, 6).Value

Your code has other problems too. For example, if for any reason it's run on a worksheet with an empty column F, it will loop all the way to the end of that column (2^20 rows in Excel 2007) then crash. The code could also be made moer efficient. You might like to consider something along the lines of:

Code:

Sub OpenURL()
Dim x%
Dim StationName, StationID, Province As String
Dim UpdateMonth As Variant
Dim UpdateYear As Integer
Dim MyStr As String
Dim fso
Dim fol As String
MyStr = Format(Date, "yyyy-mm-dd")
With Workbooks("Workbook1.xls").Sheets("Sheet1")
    For x = 18 To .UsedRange.Rows.Count
        If Len(Trim(Replace(Cells(1, "F").Value, Chr(160), Chr(32)))) > 0 Then
            Workbooks.Open Filename:=Cells(x, "F").Value
            With ActiveWorkbook
                With .ActiveSheet
                    StationName = .Cells(1, 2)
                    StationID = .Cells(6, 2)
                    UpdateMonth = .Cells(18, 3)
                    UpdateYear = .Cells(18, 2)
                    Province = .Cells(2, 2)
                End With
                'Following code creates folder in data with today's date and Station Name,
                ' but only if folder doesn't already exist.
                fol = "S:\Project1\" & MyStr & " " & StationName
                Set fso = CreateObject("Scripting.FileSystemObject")
                If Not fso.FolderExists(fol) Then
                    fso.CreateFolder (fol)
                End If
                .SaveAs Filename:="S:\Project1\" & MyStr & " " & StationName & "\" & UpdateYear & "_" _
                    & UpdateMonth & "_" & StationName & "_" & StationID & ".xls", FileFormat:=xlNormal
                '.Close SaveChanges = True
            End With
        End If
    Next x
End With
End Sub

The above revision avoids the endless loop risk and runs more efficiently due to avoidance of unnecessary selection & copy operations, and by requiring variables to be declared only once. I think it's structure is easier to follow this way.

Cheers

[MS MVP - Word]

Marisoleil · Sep 11, 2007

Hello All

Thanks again for suggestions and tips, and for the great editing, macropod. Very helpful for me for learning, I went through all the edits.

The bug is still in the program though. What could the issue be at this point?

Bob Rashkin, I did try your suggestion, just to see. Same bug results.

The formulaic contents of the cells being looped though look like:

Code:

 =IF(AND('sheet1'!B31<='sheet1'!$K$11,'Sheet1'!B31>='Sheet1'!$K$8),CONCATENATE( 'Sheet1'!$A$4, 'Sheet1'!$B$11,"&Year=", 'Sheet1'!D31, "&Month=", 'Sheet1'!E31, "&Day=1&format=csv&type=hly"),"")

I also tried this with " " instead of "" to be the blank cell placeholder. The result in the non-blank cell begins with "

http://www.etcetera=csv&type=hly",

if this provides a clue or provokes an idea.

The bug occurs at "Open Workbook" near the beginning of the loop.

Cheers,
Marie

macropod · Sep 11, 2007

Hi Marie,

Are you sure the code's failing on a 'blank' cell? Try testing the code by adding the line:

Code:

MsgBox "F" & x & ": """ & Cells(x, "F").Value & """"

after the first If statement, so that you can see what's being returned for each row - whatever is being matched will be between a pair of double quotes. The last of these to appear will be the one you're having problems with.

BTW, I just noticed an error in my code. Replace '1' with 'x' in the line:

Code:

If Len(Trim(Replace(Cells(1, "F").Value, Chr(160), Chr(32)))) > 0 Then

Also, if you expect the code to exit after the first match is found and processed, add 'Exit Sub' before the last 'End If'.

Cheers

[MS MVP - Word]

Bong · Sep 12, 2007

What, exactly, is the contents of the cell at row 18, column 6?

_________________
Bob Rashkin

Marisoleil · Sep 12, 2007

Hi Again All,

I've been at it for a few hours today with this code and have taken some steps forward and some back.

Bob: To answer your question, the contents of Row 18, Col 6 is an If-Then formula which displays within the cell a URL address. (See my most recent message before this one in this thread for the details).

Macropod, do you think you are up for another crack at editing? I have added more code to my procedure, as I would like to 'compile' data within the downloaded files into one large file. For the very first download in the series, I want to copy headers and data, and for all the others, just the data. Below is how I've begun going about it, but the problem is that now the macro is bugging at:

Code:

Workbooks.Open Filename:=Cells(x, "F").Value

near the beginning of the loop, as it is taking the x, "F" value from the newly created workbook of compiled data rather than the master Aut Dwnld one. (So far, I have not had results that go beyond the creation and saving of the newly compiled workbook at the end of the first loop, that is, no second loop happening). I tried a 'With Workbooks just before this line, to call attention to the Aut dwnlds workbook and not the newly downloaded workbook. I seem to have trouble toggling back and forth between open workbooks.

Code:

Dim x%                                  
Dim StnName, StnID, Prov, FMonth, FYear, LMonth, LYear, MostRecent, fname, fname2, MyStr, fol, fol2, fol3 As String
Dim UpdateMth, UpdateYr, FMthCal, LMthCal As Variant
Dim fso, fso2, fso3
MyStr = Format(Date, "yyyy-mm-dd")
With Workbooks("Aut dwnld(ver3).xls").Sheets("aut dwnlds")
    For x = 18 To .UsedRange.Rows.Count
        If Len(Trim(Replace(Cells(x, "F").Value, Chr(160), Chr(32)))) > 1 Then
            Workbooks.Open Filename:=Cells(x, "F").Value
            With ActiveWorkbook
                With .ActiveSheet
                    StnName = .Cells(1, 2)
                    StnID = .Cells(6, 2)
                    UpdateMth = .Cells(18, 3)
                    UpdateYr = .Cells(18, 2)
                    Prov = .Cells(2, 2)
                End With
                'following code creates folder in in.data with today's date and Station Name, but only if folder doesn't already exist
                fol = "S:\in.data\" & MyStr & " " & StationName
                Set fso = CreateObject("Scripting.FileSystemObject")
                If Not fso.FolderExists(fol) Then
                    fso.CreateFolder (fol)
                End If
                .SaveAs Filename:="S:\in.data\" & MyStr & " " & StnName & "\" & UpdateYr & "_" & UpdateMth & "_" & StnName & "_" & StnID & ".xls", FileFormat:=xlNormal
            End With
            With Workbooks("Aut dwnld(ver3).xls").Sheets("aut dwnlds")
                FMth = .Cells(7, "G")
                FYr = .Cells(8, "G")
                LMth = .Cells(10, "G")
                LYr = .Cells(11, "G")
                FMthCal = MonthName(FMth, True)
                LMthCal = MonthName(LMth, True)
                MostRecent = "Update " & FMthCal & FYr & " - " & LMthCal & LYr
                'Following code creates 'Work' folder in specific Station folder, but only if it doesn't already exist.
                fol3 = "S:\Proc\" & Prov & "\" & StnID & " - " & StnName & "\Work"
                Set fso3 = CreateObject("Scripting.FileSystemObject")
                If Not fso3.FolderExists(fol3) Then
                    fso3.CreateFolder (fol3)
                End If
            End With
            'Following code creates folder in specific Station's Work.    
            fol2 = "S:\Proc\" & Prov & "\" & StnID & " - " & StnName & "\Work\" & MostRecent
            Set fso2 = CreateObject("Scripting.FileSystemObject")
            If Not fso2.FolderExists(fol2) Then
                fso2.CreateFolder (fol2)
            End If
            fname = UpdateYr & "_" & UpdateMth & "_" & StnName & "_" & StnID & ".xls"
            ActiveWorkbook.SaveAs Filename:= "S:\Proc\" & Prov & "\" & StnID & " - " & StnName & "\Work\" & MostRecent & "\" & fname, FileFormat:=xlNormal
            If x = 18 Then
                Range("A17").Select
                Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
                Selection.Copy
                Workbooks.Add
                ActiveSheet.Paste
                Columns("A:A").EntireColumn.AutoFit
                fname2 = "01" & MostRecent & "_" & StnName & ".xls"
                ActiveWorkbook.SaveAs Filename:="S:\Proc\" & Prov & "\" & StnID & " - " & StnName & "\Work\" & MostRecent & "\" & fname2, FileFormat:=xlNormal
            End If
            If x > 18 Then
                 Range("A18").Select
                 Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
                 Selection.Copy
                 With Workbooks(fname2).Sheets("Sheet1")
                 Range("A1").Select
                 Selection.End(xlDown).Select
                 'I need to insert a command here to select new Selection which is one cell (row) downwards from old selection, as prev command brings me to last row of old data pasted, but now I want to paste new data in row beginning after this.
                 Selection.Paste
                 ActiveWorkbook.Save
            End If
        End If
    Next x
End With
End Sub

Any comments and suggestions are welcome,
Cheers,
Marie

macropod · Sep 12, 2007

Hi Marie,

I'll have a look at this later, but first: Did you get the code working before adding in the extra material?

Cheers

[MS MVP - Word]

Marisoleil · Sep 12, 2007

Hi Macropod,
It worked, yes, but still bugged at the end on the empty (displayed value) cell.
You have got tenacity and generosity of spirit, if you are willing to look at this again, or maybe just a mind for puzzles.

Thanks,
Marie

macropod · Sep 12, 2007

Hi Marie,

If I understand the issues correctly, the following should do the job:

Code:

Sub OpenURL()
Dim x As Integer
Dim DnLdWkBk, DnLdWkSht, StnWkBk, StnName, StnID, Prov, FMth, FYr, LMth, LYr As String
Dim MostRecent, fname1, fname2, fname3, DtStr, fol As String
Dim UpdateMth, UpdateYr, FMthCal, LMthCal, ObjFile, ObjFileName, fso
Set fso = CreateObject("Scripting.FileSystemObject")
DtStr = Format(Date, "yyyy-mm-dd")
DnLdWkBk = "Aut dwnld(ver3).xls"
DnLdWkSht = "aut dwnlds"
With Workbooks(DnLdWkBk).Sheets(DnLdWkSht)
    FMth = .Cells(7, "G")
    FYr = .Cells(8, "G")
    LMth = .Cells(10, "G")
    LYr = .Cells(11, "G")
    FMthCal = MonthName(FMth, True)
    LMthCal = MonthName(LMth, True)
    MostRecent = "Update " & FMthCal & FYr & " - " & LMthCal & LYr
    For x = 18 To .Cells.SpecialCells(xlCellTypeLastCell).Row
        If Len(Trim(Replace(Cells(x, "F").Value, Chr(160), Chr(32)))) > 0 Then
            Workbooks.Open Filename:=Cells(x, "F").Value
            'Strip off the path, leaving just the workbook name.
            ObjFileName = Split(Cells(x, "F").Value, "\")
            For Each ObjFile In ObjFileName
                StnWkBk = ObjFile
            Next
            With Workbooks(StnWkBk) 'Use the returned name to refer to the workbook explicitly.
                'This avoids problems that can be caused by changing the active workbook.
                With .Sheets("Sheet1") 'Refer to the worksheet by name explicitly.
                'This avoids problems that can be caused by the workbook being saved with
                'a different active sheet, or the sheet order being changed.
                    StnName = .Cells(1, 2)
                    StnID = .Cells(6, 2)
                    UpdateMth = .Cells(18, 3)
                    UpdateYr = .Cells(18, 2)
                    Prov = .Cells(2, 2)
                End With
                'Create folder in "in.data" with today's date and Station Name if folder doesn't already exist.
                fol = "S:\in.data\" & DtStr & " " & StnName 'Not 'StationName'
                'Define the filename. This allows further access if needed without worrying about which workbook is active.
                fname1 = UpdateYr & "_" & UpdateMth & "_" & StnName & "_" & StnID & ".xls"
                If Not fso.FolderExists(fol) Then fso.CreateFolder (fol)
                .SaveAs Filename:=fol & "\" & fname1, FileFormat:=xlNormal
            End With
            'Create 'Work' folder in specific Station folder if it doesn't already exist.
            fol = "S:\Proc\" & Prov & "\" & StnID & " - " & StnName & "\Work"
            If Not fso.FolderExists(fol) Then fso.CreateFolder (fol)
            'Creates folder in specific Station's Work if it doesn't already exist.
            fol = fol & "\" & MostRecent '**********
            'Define the filename. This allows further access if needed without worrying about which workbook is active.
            fname2 = UpdateYr & "_" & UpdateMth & "_" & StnName & "_" & StnID & ".xls"
            If Not fso.FolderExists(fol) Then fso.CreateFolder (fol)
            'Save the active workbook
            ActiveWorkbook.SaveAs Filename:=fol & "\" & fname2, FileFormat:=xlNormal '**********
            'Define the filename. This allows further access if needed without worrying about which workbook is active.
            fname3 = "01" & MostRecent & "_" & StnName & ".xls"
            If x = 18 Then
                'Make sure we get the data from the right workbook
                Workbooks(DnLdWkBk).Sheets(DnLdWkSht).Range("A17", ActiveCell.SpecialCells(xlLastCell)).Copy
                Workbooks.Add
                ActiveSheet.Paste
                Columns("A:A").EntireColumn.AutoFit
                ActiveWorkbook.SaveAs Filename:=fol & "\" & fname3, FileFormat:=xlNormal '**********
            Else
                'Make sure we get the data from the right workbook
                 Workbooks(DnLdWkBk).Sheets(DnLdWkSht).Range("A18", ActiveCell.SpecialCells(xlLastCell)).Copy
                 Workbooks(fname3).Sheets("Sheet1").Paste Range("A1").Offset(.Cells.SpecialCells(xlCellTypeLastCell).Row, 0)
                ActiveWorkbook.Save
            End If
        End If
    Next x
End With
End Sub

I've put some comments in the code, to explain what I've done. By referring to the workbooks you want to act on, you can avoid issues concerning which workbook is active.

Cheers
PS: You might want to close some of the newly-created workbooks as you go, rather than leaving them all open. That'll improve performance and stability.

[MS MVP - Word]

Marisoleil · Sep 13, 2007

Hello Macropod,
Many Thanks! There were a few little adjustments I was able to make, but just one remaining problem. Maybe you could offer further thoughts on:

Code:

Workbooks(fname3).Sheets("Sheet1").Range("A1").Offset(.Cells.SpecialCells(xlCellTypeLastCell).Row, 0).Paste

It's the line right near the end of the loop, for the "Else" condition. I think the problem might be with the .Cells.SpecialCells...?

Here's the entire 'Else' loop below. Note that I added in some extra workbk, worksht reference, as the program kept pasting the extra info in the fname2 worksheet (that is, the same one it was copying it from).

Code:

Else
   With Workbooks(fname2).Sheets("bulkdata_e")
      Range("A18", ActiveCell.SpecialCells(xlLastCell)).Copy
   End With
   With Workbooks(fname3).Sheets("Sheet1")
      Workbooks(fname3).Sheets("Sheet1").Range("A1").Offset(.Cells.SpecialCells(xlCellTypeLastCell).Row, 0).Paste
      Workbooks(fname3).Save
   End With
End If


Thank you Again, it was nicely informative once more for me to go through your last edit.

Cheers, Marie

p.s. I include below adjustments I made to the last code you gave me, just in case it is of interest for you.  Feel free to comment on robustness of my changes, but please don't feel it necessary, as you've done so much for me with this already!:

1.  There was the same trouble as before: the second run of the loop started out retrieving the (x, "F") value from the newly created workbook which the loop ended off with, rather than accessing the master aut dwnlds workbook.  I added an 'Activate' command for the master download workbook at the very end of the loop, and this seems to have fixed this.  

2.  The last edited code which you posted didn't complete its first loop, as it bugged near the start of the loop at:[code]With Workbooks(StnWkBk)

citing 'subscript out of range'. I should have included before that the workbook downloads always arrive with the file name: "bulkdata_e.html" and worksheet name: "bulkdata_e". I think this problem is solved, as in the code you gave me, I replaced "Sheet1" with "bulkdata_e" within the "With. Sheets" command, and took out the lines to strip the path(good to know, by the way -thnx), and put in StnWkBk = "bulkdata_e.html". (This is okay, yes?)
(To add to this: The workbook file name or sheet name 'bulkdata_e' isn't contained in the URL address in cell (x,"F") of the aut dwnld workbook.)

3. "Select Method of Range Class failed" for the line:

Code:

Workbooks(DnLdWkBk).Sheets(DnLdWkSht).Range("A17", ActiveCell.SpecialCells(xlLastCell)).Copy

I replaced this with the following, but wonder if the line above should work somehow, as the sheet is the parent of the range or cells, I don't know why I always have the above trouble that I can't call "workbooks().sheets().cells()" without trouble:

Code:

With Workbooks(DnLdWkBk).Sheets(DnLdWkSht)
    Range("A17", ActiveCell.SpecialCell(xlLastCell)).Copy  
End With

Marisoleil · Sep 13, 2007

Hi Again Macropod,
Sorry to add to that last post: I did try that 'Offset' line exactly as you had posted it first. When it bugged, then I tried altering the command to the form you see as I last posted it.

Cheers,
Marie

macropod · Sep 13, 2007

Hi Marie,

I'm confused. Do you still have a problem you need help with?

Cheers

[MS MVP - Word]

Marisoleil · Sep 13, 2007

I did up until sixty seconds ago!

The last If-Then-Else had a strange quirk when executing the Else condition: the code explicity states for the copied data (from fname2) to be pasted to workbook fname3; however, it was being pasted to workbook fname2 (the same workbook the data was copied from). The very interesting thing however was that the data was pasted beginning in row 746(in one example -it won't always be this row), which is not the first blank row after the dataset in the book copied from (fname2), but rather it corresponds to the first blank row in fname3.
Old Code which produced this result:

Code:

fname3 = "01" & MostRecent & "_" & StnName & ".xls"
If x = 18 Then
    With Workbooks(fname2).Sheets("bulkdata_e")
        Range("A17", ActiveCell.SpecialCells(xlLastCell)).Copy
        End With
        Workbooks.Add
        ActiveSheet.Paste
        Columns("A:A").EntireColumn.AutoFit
        Range("A1").Select
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:=fol & "\" & fname3, FileFormat:=xlNormal
    Else
        With Workbooks(fname2).Sheets("bulkdata_e")
            Range("A18", ActiveCell.SpecialCells(xlLastCell)).Copy
        End With
        With Workbooks(fname3).Sheets("Sheet1")
            Workbooks(fname3).Sheets("Sheet1").Paste Range("A1").Offset(.Cells.SpecialCells(xlCellTypeLastCell).Row, 0)
            Workbooks(fname3).Save
        End With
            End If

Now it seems it is fixed! In the 4th last line, before Range("A1").Offset(etc...), I added Workbooks(fname3).Sheets("Sheet1") once again, and that seems to have done it!

Macropod, Thanks again for your help with this all the way through.

Cheers,
Marie

firefytr · Sep 16, 2007

When you open a workbook, there is little need to loop or set anything. You only need the path and name of the workbook, the rest is variable history.

Use a function...

Code:

function WbOpen(wbName as string) as boolean
    on error resume next
    wbopen = len(workbooks(wbname).name)
end function

Then, in a practical application, just test for the existence...

Code:

If wbopen("Name.xls") = true then
    set wb = workbooks("Name.xls")
else
    set wb = workbooks.open("C:\Path\Name.xls")
end if

Once you hook it as a variable, no need to use ActiveWorkbook, or loop for the variable. That can get waaay too messy also. Plus just being a pain.

Anytime you work with a workbook or worksheet you should either use a variable or a With statement (imho). So you could take the loop out (looking for the filename) from this..

Code:

ObjFileName = Split(Cells(x, "F").Value, "\")
For Each ObjFile In ObjFileName
    StnWkBk = ObjFile
Next

... to this ...

Code:

ObjFileName = Split(.Cells(x, "F").Value, "\")(Len(.Cells(x, "F").Value) - Len(Replace(.Cells(x, "F").Value, "\", "")))

Or set the variable as an array [variable] and grab the Ubound() of it. Arrays are very fast as well. Much faster than looping.

Regarding variables, take a look at these...

Code:

    Dim DnLdWkBk, DnLdWkSht, StnWkBk, StnName, StnID, Prov, FMth, FYr, LMth, LYr As String
    Dim MostRecent, fname1, fname2, fname3, DtStr, fol As String
    Dim UpdateMth, UpdateYr, FMthCal, LMthCal, ObjFile, ObjFileName, fso

These are all variants. In larger procedures (this is small-mediocre) this can be a collosal waste of memory and just bad programming habits. Plus it can lead to some variable pitfalls. You should define the scope of all your variables. If one is going to be an oddity, set it explicitly as Variant type.

As far as finding the last row, both SpecialCells(xlCellTypeLastCell).Row and UsedRange.Rows.Count are not reliable. Instead, use the Find method..

Code:

.Cells.Find(what:="*", after:=.Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row

You can set these to custom functions as well if you like. This can be handy, but not everyone will take the time to set these up. If you do, you can find quite a few of them here..

http://vbaexpress.com/kb/default.php?action=list&appsel=0&authsel=1469

(you must register/login to view this. Here is an example of a Last Row UDF...

Code:

Function xlFirstRow(Optional WorksheetName As String) As Long 
     
     '    find the first populated row in a worksheet
     
    If WorksheetName = vbNullString Then WorksheetName = ActiveSheet.Name 
    With Worksheets(WorksheetName) 
        On Error Resume Next 
        xlFirstRow = .Cells.Find("*", .Cells(.Cells.Count), xlFormulas, _ 
        xlWhole, xlByRows, xlNext).Row 
        If Err <> 0 Then xlFirstRow = 0 
    End With 
     
End Function 
 
Function xlLastRow(Optional WorksheetName As String) As Long 
     
     '    find the last populated row in a worksheet
     
    If WorksheetName = vbNullString Then WorksheetName = ActiveSheet.Name 
    With Worksheets(WorksheetName) 
        On Error Resume Next 
        xlLastRow = .Cells.Find("*", .Cells(1), xlFormulas, _ 
        xlWhole, xlByRows, xlPrevious).Row 
        If Err <> 0 Then xlLastRow = 0 
    End With 
     
End Function

The only thing this does not take into account is the workbook. It assumes the activeworkbook, which I am not a fan of, but you see how they did this with the worksheet. Same principle.

I'm sure this could be tidied up more, but ...

Code:

Sub OpenURL()
    Dim x As Integer, wb As Workbook, wb18 As Workbook, rngCopy As Range, wsDnLd As Worksheet
    Dim DnLdWkBk, DnLdWkSht, StnWkBk, StnName, StnID, Prov, FMth, FYr, LMth, LYr As String
    Dim MostRecent, fname1, fname2, fname3, DtStr, fol As String
    Dim UpdateMth, UpdateYr, FMthCal, LMthCal, ObjFile, ObjFileName, fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    DtStr = Format(Date, "yyyy-mm-dd")
    DnLdWkBk = "Aut dwnld(ver3).xls"
    DnLdWkSht = "aut dwnlds"
    Set wsDnLd = Workbooks(DnLdWkBk).Sheets(DnLdWkSht)
    FMth = wsDnLd.Cells(7, "G")
    FYr = wsDnLd.Cells(8, "G")
    LMth = wsDnLd.Cells(10, "G")
    LYr = wsDnLd.Cells(11, "G")
    FMthCal = MonthName(FMth, True)
    LMthCal = MonthName(LMth, True)
    MostRecent = "Update " & FMthCal & FYr & " - " & LMthCal & LYr
    For x = 18 To wsDnLd.Cells.SpecialCells(xlCellTypeLastCell).Row
        If Len(Trim(Replace(wsDnLd.Cells(x, "F").Value, Chr(160), Chr(32)))) > 0 Then
            Set wb = Workbooks.Open(Filename:=wsDnLd.Cells(x, "F").Value)
            StnName = wb.Sheets("Sheet1").Cells(1, 2)
            StnID = wb.Sheets("Sheet1").Cells(6, 2)
            UpdateMth = wb.Sheets("Sheet1").Cells(18, 3)
            UpdateYr = wb.Sheets("Sheet1").Cells(18, 2)
            Prov = wb.Sheets("Sheet1").Cells(2, 2)
            fol = "S:\in.data\" & DtStr & " " & StnName    'Not 'StationName'
            fname1 = UpdateYr & "_" & UpdateMth & "_" & StnName & "_" & StnID & ".xls"
            If Not fso.FolderExists(fol) Then fso.CreateFolder (fol)
            wb.SaveAs Filename:=fol & "\" & fname1, FileFormat:=xlNormal
            fol = "S:\Proc\" & Prov & "\" & StnID & " - " & StnName & "\Work"
            If Not fso.FolderExists(fol) Then fso.CreateFolder (fol)
            fol = fol & "\" & MostRecent    '**********
            fname2 = UpdateYr & "_" & UpdateMth & "_" & StnName & "_" & StnID & ".xls"
            If Not fso.FolderExists(fol) Then fso.CreateFolder (fol)
            wb.SaveAs Filename:=fol & "\" & fname2, FileFormat:=xlNormal    '**********
            fname3 = "01" & MostRecent & "_" & StnName & ".xls"
            If x = 18 Then
                Set rngCopy = wsDnLd.Range("A17", wsDnLd.Cells.SpecialCells(xlLastCell))
                Set wb18 = Workbooks.Add(xlWBATWorksheet)    '- only use one worksheet
                wb18.Sheets(1).Range(rngCopy.Address).Value = rngCopy.Value
                wb18.Sheets(1).Columns("A:A").EntireColumn.AutoFit
                wb18.SaveAs Filename:=fol & "\" & fname3, FileFormat:=xlNormal    '**********
            Else
                'Not sure what you want to do here, but this can be revised as well...
                Set rngCopy = wsDnLd.Range("A18", ActiveCell.SpecialCells(xlLastCell))
                Workbooks(fname3).Sheets("Sheet1").Paste Range("A1").Offset(Cells.SpecialCells(xlCellTypeLastCell).Row, 0)
                ActiveWorkbook.Save
            End If
        End If
    Next x
End Sub

HTH

Regards,
Zack Barresse

Simplicity is the ultimate sophistication. What is a MS MVP? PODA
- Leonardo da Vinci

Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Do While Cells(x, &quot;F&quot;).Value &lt;&gt; &quot; &quot; 5

MIS

Technical User

MIS

MIS

Technical User

MIS

Programmer

Technical User

MIS

Technical User

Programmer

MIS

Technical User

MIS

Technical User

MIS

MIS

Technical User

MIS

Technical User

Similar threads

Log in

Part and Inventory Search

Sponsor

Do While Cells(x, "F").Value <> " " 5