Wrox Programmer Forums
Go Back   Wrox Programmer Forums > Microsoft Office > Excel VBA > Excel VBA
|
Excel VBA Discuss using VBA for Excel programming.
Welcome to the p2p.wrox.com Forums.

You are currently viewing the Excel VBA section of the Wrox Programmer to Programmer discussions. This is a community of software programmers and website developers including Wrox book authors and readers. New member registration was closed in 2019. New posts were shut off and the site was archived into this static format as of October 1, 2020. If you require technical support for a Wrox book please contact http://hub.wiley.com
 
Old April 26th, 2011, 10:15 AM
Friend of Wrox
 
Join Date: Jan 2011
Posts: 103
Thanks: 7
Thanked 0 Times in 0 Posts
Default changing a loop so it loops through certain files within a folder

Hi

I have this macro which i have been working on fro a couple weeks but i ahve been told i have to change it.

this is my code
Code:
Option Base 1
Option Explicit
Sub DealerGraphingDraft()

Dim Nrow As Long, Nrow1 As Long, Nrow2 As Long, Nrow3 As Long, Nrow4 As Long, Nrow5 As Long
Dim strF, strFile, strFile1, strFile2, strFile3, strFile4, strFile5, strFile6, strFile7, strFile8 As String
Dim strFile9, strFile10, strFile11, strFile12, strFile13, strFile14, strFile15, strFile16, strFile17 As String
Dim i, l, k, e, g, h, strFldr, strFldr2, strFldr3, Lction As String: Dim wbResults, wbGCT, wbNew, PWorkbook As Workbook
Dim varFolder, sht, sht1, sht2, varsheet, varsheets As Variant: Dim lngMyCount As Long

Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.EnableEvents = False

'Variable setting
strFldr = "C:\Documents and Settings\SeymourJ\My Documents\Tasks\": Lction = "C:\Documents and Settings\SeymourJ\Desktop\"
strFldr2 = "C:\Documents and Settings\SeymourJ\My Documents\Tasks2\": strFldr3 = "C:\Documents and Settings\SeymourJ\My Documents\Tasks3\"
strFile = "Graphing_MTH_Actual_Curr_Year*.csv": strFile1 = "Graphing_MTH_Actual_Prev_Year*.csv"
strFile2 = "Graphing_YTD_Actual_Curr_Year*.csv": strFile3 = "Graphing_YTD_Actual_Prev_Year*.csv"
strFile4 = "Graphing_R12_Actual_Curr_Year*.csv": strFile5 = "Graphing_R12_Actual_Prev_Year*.csv"
strFile6 = "Graphing_MTH_Actual_Curr_Year_National_Average_NoSample.csv"
strFile7 = "Graphing_MTH_Actual_Curr_Year_UpperQuartile_TRUE_NoSample.csv"
strFile8 = "Graphing_MTH_Actual_Prev_Year_National_Average_NoSample.csv"
strFile9 = "Graphing_MTH_Actual_Prev_Year_UpperQuartile_TRUE_NoSample.csv"
strFile10 = "Graphing_YTD_Actual_Curr_Year_National_Average_NoSample.csv"
strFile11 = "Graphing_YTD_Actual_Curr_Year_UpperQuartile_TRUE_NoSample.csv"
strFile12 = "Graphing_YTD_Actual_Prev_Year_National_Average_NoSample.csv"
strFile13 = "Graphing_YTD_Actual_Prev_Year_UpperQuartile_TRUE_NoSample.csv"
strFile14 = "Graphing_R12_Actual_Curr_Year_National_Average_NoSample.csv"
strFile15 = "Graphing_R12_Actual_Curr_Year_UpperQuartile_TRUE_NoSample.csv"
strFile16 = "Graphing_R12_Actual_Prev_Year_National_Average_NoSample.csv"
strFile17 = "Graphing_R12_Actual_Prev_Year_UpperQuartile_TRUE_NoSample.csv"
Nrow = 2: Nrow1 = 2: Nrow2 = 2: Nrow3 = 2: Nrow4 = 2: Nrow5 = 2
i = Range("B7").Value: l = Range("B8").Value

'sorting, filtering and copying the list of dealers codes and names from the Participation document
Set wbGCT = Workbooks.Open(Lction & "GraphingChartTemplate.xlsx")
Set PWorkbook = Application.Workbooks.Open(Lction & "Actual_Participation_" & i & "_" & l & ".xls")

PWorkbook.Sheets(1).Select
Range("C1:N1").AutoFilter Field:=i, Criteria1:="<>"
PWorkbook.Sheets(1).Range("A2:A1000").Copy Destination:=wbGCT.Sheets("Graphing").Range("A3")

With Sheets(1)
    k = WorksheetFunction.CountA(.Range("A:A"))
    .Range("A2:AQ" & k).Sort Key1:=.Columns("B"), Order1:=xlAscending
End With

PWorkbook.Sheets(1).Range("B2:B" & k).Copy Destination:=wbGCT.Sheets("Graphing").Range("D3")
PWorkbook.Sheets(1).Range("A2:A1000").Copy Destination:=wbGCT.Sheets("Graphing").Range("C3")
PWorkbook.Close

'Add dates to template
ActiveWorkbook.Sheets("Settings").Select
Range("B6").Value = i: Range("B7").Value = l

'Create new workbook
Set wbNew = Application.Workbooks.Add
Sheets.Add.Name = ("MTH"): Sheets.Add.Name = ("MTHPrevious"): Sheets.Add.Name = ("YTD")
Sheets.Add.Name = ("YTDPrevious"): Sheets.Add.Name = ("R12"): Sheets.Add.Name = ("R12Previous")

varFolder = Array(strFldr, strFldr2, strFldr3)

'Loop to go through dealer graphing folder, open the files and copy the data
For lngMyCount = 1 To 3

ChDir varFolder(lngMyCount)
strF = Dir("Graphing_*_Actual_*_Year*.csv")
Do While strF <> ""
Set wbResults = Workbooks.Open(varFolder(lngMyCount) & "\" & strF)
        wbResults.Sheets(1).Range("A2:FF15").Copy

'If statement to paste the data into the correct sheet
If wbResults.Name Like strFile Then
        wbNew.Sheets("MTH").Cells(Nrow, 2).PasteSpecial
        Nrow = Nrow + 14
    ElseIf wbResults.Name Like strFile1 Then
        wbNew.Sheets("MTHPrevious").Cells(Nrow1, 2).PasteSpecial
        Nrow1 = Nrow1 + 14
    ElseIf wbResults.Name Like strFile2 Then
        wbNew.Sheets("YTD").Cells(Nrow2, 2).PasteSpecial
        Nrow2 = Nrow2 + 14
    ElseIf wbResults.Name Like strFile3 Then
        wbNew.Sheets("YTDPrevious").Cells(Nrow3, 2).PasteSpecial
        Nrow3 = Nrow3 + 14
    ElseIf wbResults.Name Like strFile4 Then
        wbNew.Sheets("R12").Cells(Nrow4, 2).PasteSpecial
        Nrow4 = Nrow4 + 14
    ElseIf wbResults.Name Like strFile5 Then
        wbNew.Sheets("R12Previous").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile6 Then
        wbNew.Sheets("MTH").Cells(Nrow, 2).PasteSpecial
        Nrow = Nrow + 14
    ElseIf wbResults.Name Like strFile7 Then
        wbNew.Sheets("MTHPrevious").Cells(Nrow1, 2).PasteSpecial
        Nrow1 = Nrow1 + 14
    ElseIf wbResults.Name Like strFile8 Then
        wbNew.Sheets("MTH").Cells(Nrow2, 2).PasteSpecial
        Nrow2 = Nrow2 + 14
    ElseIf wbResults.Name Like strFile9 Then
        wbNew.Sheets("MTHPrevious").Cells(Nrow3, 2).PasteSpecial
        Nrow3 = Nrow3 + 14
    ElseIf wbResults.Name Like strFile10 Then
        wbNew.Sheets("YTD").Cells(Nrow4, 2).PasteSpecial
        Nrow4 = Nrow4 + 14
     ElseIf wbResults.Name Like strFile11 Then
        wbNew.Sheets("YTDPrevious").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile12 Then
        wbNew.Sheets("YTD").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile13 Then
        wbNew.Sheets("YTDPrevious").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile14 Then
        wbNew.Sheets("R12").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile15 Then
        wbNew.Sheets("R12Previous").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile16 Then
        wbNew.Sheets("R12").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile17 Then
        wbNew.Sheets("R12Previous").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
End If
        wbResults.Close SaveChanges:=False
        Application.StatusBar = strF
        strF = Dir
Loop

Next lngMyCount

'Copying data from new workbook into Template and closing new workbook
Application.StatusBar = "Copying data"

varsheets = Array("R12Previous", "R12", "YTDPrevious", "YTD", "MTHPrevious", "MTH")

For Each varsheet In varsheets
   wbNew.Sheets(varsheet).Range("B2:FF4000").Copy
wbGCT.Sheets(varsheet).Range("B2:FF4000").PasteSpecial
Next varsheet

wbNew.Close

'Set the Dealer Name drop down box
g = WorksheetFunction.CountA(Sheets("Graphing").Range("D3:D183"))
Sheets("Charts").Shapes("Drop Down 1").ControlFormat.ListFillRange = "Graphing!$E$3:$E$" & g

'select A1 on all sheetsSave Full version
Application.StatusBar = "Savinf full version"
For Each sht1 In Array("Graphing", "Settings", "R12Previous", "R12", "YTDPrevious", "YTD", "MTHPrevious", "MTH", "Charts", "Home")
    Sheets(sht1).Select: Range("A1").Select
Next

wbGCT.SaveAs (strFldr & "Executive_AnalysisFull_" & i & "_" & l)

'Hide Sheets
Application.StatusBar = "formatting document and Saving ranged value version"
For Each sht In Array("Graphing", "Settings", "R12Previous", "R12", "YTDPrevious", "YTD", "MTHPrevious", "MTH")
    Sheets(sht).Visible = xlSheetVeryHidden
Next

'Remove formatting
Sheets("Charts").Select: Cells.Select: Selection.Copy: Selection.PasteSpecial Paste:=xlPasteValues
Sheets("Charts").Select: Range("A1").Select
ActiveSheet.Protect Password:="256;999;666"

Sheets("Home").Select: Cells.Select: Selection.Copy: Selection.PasteSpecial Paste:=xlPasteValues
Sheets("Home").Select: Range("A1").Select

'Save dealer version and close
ActiveWorkbook.SaveAs (strFldr & "Executive_Analysis_" & i & "_" & l)

ActiveWorkbook.Close
Application.StatusBar = "Executive Analysis Macro Finsihed"
End Sub
However i need to change this that instead of looping through the array folders and looking at every folder it goes through a list in a range of A1:3000 on sheet 1 in wbNew workboook.

I was wondering if it can be done by changing this line "strF = Dir("Graphing_*_Actual_*_Year*.csv")" so that instead of having the last * it has a variable or something like that, but i dont know.

Does anyone know how i can do this?

Thanks

Jeskit
 
Old April 26th, 2011, 06:26 PM
Friend of Wrox
 
Join Date: Sep 2010
Posts: 171
Thanks: 0
Thanked 14 Times in 14 Posts
Default

Not sure what you're asking Jeskit. I'm guessing you're saying that the range A1:A3000 is now going to contain all the file names or just the part of the file name that comes after "Year" and that's what you need to loop through? Either way, yes, just loop through the cells something like this
Code:
Option Explicit

Sub sTryThis()
Dim lCurrRow As Long

'Sheet1 is the name NOT in parantheses over in the project explorer (you can change that name to whatever you want in the properties window). Using that name instead of Sheets("Sheet1") will give you intellisense when you type code.

With Sheet1 
    For lCurrRow = 1 To 3000
        'if the cell has the file name
        strF = Dir(.Cells(lCurrRow, 1))
        'if the cell has the part of the file name that comes after "Year"
        strF = Dir("Graphing_*_Actual_*_Year" & .Cells(lCurrRow, 1) & ".csv")
    Next
End With

End Sub
I didn't test that code so you'll have to debug. But you use the concatenation operator "&" to build a string and you can mix hard-coded parts, variable parts, what ever as i did in the second StrF = Dir().

One thing to KNOW about the concatenation operator (dunno if it applies to all versions of VBA) is that you should always put a space before and after it, otherwise sometimes the code will throw an error.

Looks like you've come a long way since the first time i saw you post on here, pretty soon I'll be asking you the questions. :)

Couple things I noticed though. One, don't forget to indent everything, it makes the code more readable for other people, and also for yourself if you have to come back to it in a year to do some changes. Second, you're declaring a lot of those variables as variants. You have to explicitly declare each variable.
Code:
'string1 and string2 are variants:
Dim string1, string2, string3 as string

'all variables are strings:
Dim string1 as string, string2 as string, string2 as string
Dunno if that's the correct password or how important it is, but you posted it.
Also, the status doesn't go back to normal behavior once you're done using it. It will say "Executive summary complete" for as long as Excel is open no matter what. I forget the code return control back to excel, I think you just call it with no parameters
Code:
'I think this returns control back to excel:
Application.StatusBar
Lastly, you have a typo:
Code:
Application.StatusBar = "Savinf full version"
Don't want the boss-man seeing that ;)

Last edited by mtranchi; April 26th, 2011 at 06:57 PM..
 
Old April 27th, 2011, 03:27 AM
Friend of Wrox
 
Join Date: Jan 2011
Posts: 103
Thanks: 7
Thanked 0 Times in 0 Posts
Default

Hi

Thanks for replying

Its rather complicated and i am not sure how to describe problem.

I had working piece of code which worked fine and did what it should do but the code looped the though the folder looking at all files which i know have to change so that instead of it looking at all the files it looks at files which are in a list.

This would not be too hard except for the fact i have three folders it needs to go through and look up the file names which are on the list. Its rather complicated but so far i have this:

Code:
varFolder = Array(strFldr, strFldr2, strFldr3)

For lngMyCount = 1 To 3

ChDir varFolder(lngMyCount)
strF = Dir("Graphing_*_Actual_*_Year*.csv")
Do While strF <> ""
Set wbResults = Workbooks.Open(varFolder(lngMyCount) & "\" & strF)
        wbResults.Sheets(1).Range("A2:FF15").Copy

'If statement to paste the data into the correct sheet
If wbResults.Name Like strFile Then
        wbNew.Sheets("MTH").Cells(Nrow, 2).PasteSpecial
        Nrow = Nrow + 14
    ElseIf wbResults.Name Like strFile1 Then
        wbNew.Sheets("MTHPrevious").Cells(Nrow1, 2).PasteSpecial
        Nrow1 = Nrow1 + 14
    ElseIf wbResults.Name Like strFile2 Then
        wbNew.Sheets("YTD").Cells(Nrow2, 2).PasteSpecial
        Nrow2 = Nrow2 + 14
    ElseIf wbResults.Name Like strFile3 Then
        wbNew.Sheets("YTDPrevious").Cells(Nrow3, 2).PasteSpecial
        Nrow3 = Nrow3 + 14
    ElseIf wbResults.Name Like strFile4 Then
        wbNew.Sheets("R12").Cells(Nrow4, 2).PasteSpecial
        Nrow4 = Nrow4 + 14
    ElseIf wbResults.Name Like strFile5 Then
        wbNew.Sheets("R12Previous").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile6 Then
        wbNew.Sheets("MTH").Cells(Nrow, 2).PasteSpecial
        Nrow = Nrow + 14
    ElseIf wbResults.Name Like strFile7 Then
        wbNew.Sheets("MTHPrevious").Cells(Nrow1, 2).PasteSpecial
        Nrow1 = Nrow1 + 14
    ElseIf wbResults.Name Like strFile8 Then
        wbNew.Sheets("MTH").Cells(Nrow2, 2).PasteSpecial
        Nrow2 = Nrow2 + 14
    ElseIf wbResults.Name Like strFile9 Then
        wbNew.Sheets("MTHPrevious").Cells(Nrow3, 2).PasteSpecial
        Nrow3 = Nrow3 + 14
    ElseIf wbResults.Name Like strFile10 Then
        wbNew.Sheets("YTD").Cells(Nrow4, 2).PasteSpecial
        Nrow4 = Nrow4 + 14
     ElseIf wbResults.Name Like strFile11 Then
        wbNew.Sheets("YTDPrevious").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile12 Then
        wbNew.Sheets("YTD").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile13 Then
        wbNew.Sheets("YTDPrevious").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile14 Then
        wbNew.Sheets("R12").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile15 Then
        wbNew.Sheets("R12Previous").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile16 Then
        wbNew.Sheets("R12").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
    ElseIf wbResults.Name Like strFile17 Then
        wbNew.Sheets("R12Previous").Cells(Nrow5, 2).PasteSpecial
        Nrow5 = Nrow5 + 14
End If
        wbResults.Close SaveChanges:=False
        Application.StatusBar = strF
        strF = wbGCT.Sheets("Graphing").Range("A3:A181")
Loop
The above code works fine and loops through the three folders and does what it should but i need to change this (annoyingly) i have been told that i just need to change the bit highlighted in red so that it loops through the list rather than using the DIR function. But i have no idea how to do this, as i would also need to error handle it so that if a name was not on the list it would skip it.

If you could help that would be great.

Thanks
 
Old April 30th, 2011, 08:40 PM
Friend of Wrox
 
Join Date: Sep 2010
Posts: 171
Thanks: 0
Thanked 14 Times in 14 Posts
Default

hey jeskit, sry, didn't see that you had replied to this thread.
Basically just use the looping structure I set up in previous post (I'm assuming this list is in a column in a spreadsheet) to get the file names and then use the open method:
Code:
Option Explicit

Dim arFolders("C:\myPath\", "C:\myPath2\", "C:\myPath\")
Dim stFile As String
Dim lCurrRow As Long
Dim i As Integer
Dim wbkCurrFile As Workbook

Sub sTryThis()

With Sheet1
    'loop through folders
    For i = LBound(arFolders) To UBound(arFolders)
        'loop through files
        For lCurrRow = 1 To 3000
            'set the column to whatever you need to grab the file name
            stFile = .Cells(lCurrRow, 1)
            'if the file doesn't exist, this will make the code just continue at the next line:
            On Error Resume Next
            Set wbkCurrFile = Workbooks.Open(arFolders(i) & stFile)
            'reset error handling
            On Error GoTo 0
            'now test to make sure we have an open workbook:
            If Not wbkCurrFile Is Nothing Then 'we have a workbook
            
                'process the file
                
                'set the workbook to nothing for the next pass
                Set wbkCurrFile = Nothing
            End If
        Next lCurrRow
    Next i
End With

End Sub

Last edited by mtranchi; April 30th, 2011 at 09:13 PM..
The Following User Says Thank You to mtranchi For This Useful Post:
jeskit (May 3rd, 2011)
 
Old May 3rd, 2011, 05:50 AM
Friend of Wrox
 
Join Date: Jan 2011
Posts: 103
Thanks: 7
Thanked 0 Times in 0 Posts
Thumbs up

Hi

Thanks works perfectly!!! Thanks very much!!!
 
Old May 3rd, 2011, 08:26 AM
Friend of Wrox
 
Join Date: Sep 2010
Posts: 171
Thanks: 0
Thanked 14 Times in 14 Posts
Default

quite welcome jeskit





Similar Threads
Thread Thread Starter Forum Replies Last Post
Changing ASP Folder Name? Ron Howerton VS.NET 2002/2003 4 December 21st, 2007 06:59 AM
break for-each loops, or limit amount of loops warhero XSLT 2 July 4th, 2007 02:18 AM
How to Zip files within a folder Udi C# 2 January 25th, 2007 12:45 AM
Files need to move different folder surendran PHP How-To 2 June 20th, 2006 10:27 PM
FILES in FOLDER luma SQL Server DTS 0 June 9th, 2005 01:53 AM





Powered by vBulletin®
Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
Copyright (c) 2020 John Wiley & Sons, Inc.