Cycle trough a year... 1

[Roxalia]

Hi,

I've done my first programming in VBA in Excel and it worked. The program copies a datefile everyday into a masterfile. Now, because I'm lazy I thought I could use the code and transform it a little for the previous years. Instead of using the today command. I would the user to select a year with a Inputbox and then cycle through that year and copy all the information in to the masterfile. With the same code from 'Open the files. Could somebody give me a help forward with this...

Best regards,
Swedish novice Roger



'Skrivet av Roger Håkanson
'
' Join today´s date with ".xls"
' Format the filnamn to match visitor files syntax

Dim filnamn As String
filnamn = Format(Now() - 1, "yymmdd") & ".xls"

'Open the files

ChDir "C:\Passage\Bosse"
Workbooks.Open "c:\passage\Bosse\Summering2006.xls"
ChDir "C:\Passage"
Workbooks.Open (filnamn)

' Copy the information for entrance

Windows(filnamn).Activate
Range("B2:B16").Select
Selection.Copy

' Paste the information for entrance

Windows("Summering2006.xls").Activate
Sheets("Huvudentre").Select
Columns("A:A").Find(What:=Date - 1, LookIn:=xlValues).Activate
ActiveCell.Offset(0, 2).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False_, Transpose:=True

' Copy the information for gallery 1

Windows(filnamn).Activate
Range("D216").Select
Selection.Copy

' Paste the information for gallery 1

Windows("Summering2006.xls").Activate
Sheets("Plan1").Select
Columns("A:A").Find(What:=Date - 1, LookIn:=xlValues).Activate
ActiveCell.Offset(0, 2).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False_, Transpose:=True

' Copy the information for gallery 3

Windows(filnamn).Activate
Range("E2:E16").Select
Selection.Copy

' Paste the information for gallery 3

Windows("Summering2006.xls").Activate
Sheets("Plan3").Select
Columns("A:A").Find(What:=Date - 1, LookIn:=xlValues).Activate
ActiveCell.Offset(0, 2).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False_, Transpose:=True

' Copy the information for gallery 4

Windows(filnamn).Activate
Range("F2:F16").Select
Selection.Copy

' Paste the information for gallery 4

Windows("Summering2006.xls").Activate
Sheets("Plan4").Select
Columns("A:A").Find(What:=Date - 1, LookIn:=xlValues).Activate
ActiveCell.Offset(0, 2).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False_, Transpose:=True

' Close the files

Windows(filnamn).Close
Windows("Summering2006.xls").Close savechanges:=True

'Application.Quit

Exit Sub

Errorhandler:
Select Case Err.Number
Case 1005
MsgBox ("There's no file with that date!")
Case Else
MsgBox (Err.Description)
End Select

End Sub

 

[rmikesmith]

Roger,

Something like the following should do what you want. I don't know what your procedure name was (you didn't include it in the code sample) so I've used ConsolidateData for my example. I did not duplicate all of your code to do the actual data copying but have indicated where it should be placed. Also, I made a slight modification to the error handler so that a message box doesn't appear each time a file is "missing".

Sub ConsolidateData()
Dim Result As Variant
Dim i As Long
Dim StartDate As Date
Dim EndDate As Date
Dim filnamn As String

   Result = Application.InputBox(Prompt:="Enter the year of the data you wish to consolidate:", Type:=1)
   If Result = "False" Then Exit Sub
   
   StartDate = DateSerial(Result, 1, 1)
   EndDate = DateSerial(Result, 12, 31)
   
   ChDir "C:\Passage\Bosse"
   Workbooks.Open "c:\passage\Bosse\Summering2006.xls"
   ChDir "C:\Passage"

   For i = StartDate To EndDate
     filnamn = Format(i, "mmddyyyy") &".xls"
     Workbooks.Open filnamn

     [i]' Existing code to copy data goes here[/i]
     
     Workbooks(filnamn).Close
   Next i

   Workbooks("Summering2006.xls").Close SaveChanges:=True

ConsolidateData_Exit:
   Exit Sub

Errorhandler:
   Select Case Err.Number
   Case 1005
     'No message; just recover & go on to next file
     Resume Next 
   Case Else
     MsgBox (Err.Description)
     Resume ConsolidateData_Exit
   End Select

End Sub

Regards,
Mike

 

[Roxalia]

Thanx,

For the recommendations. The cycling works but when it comes to paste in the information in the file at the right position I don't know how to transform it. For example:

The original code: Columns("A:A").Find(What:=Date -1, LookIn:=xlValues).Activate

The Find(What:=DATE... should be replaced with something hinting to the actual date in the loop, VARIABEL = Format(i, "yyyy-mm-dd").

Could you use the find commando with the above suggested VARIABEL instead or?

The second thing that happended is that the Errorhandler stopped the process everytime a file was missing.

Best regards,
Roger
A curious swedish guy

THE CODE:

Sub Yearcopy()

Dim Result As Variant
Dim i As Long
Dim StartDate As Date
Dim EndDate As Date
Dim filnamn As String

Result = Application.InputBox(Prompt:="Enter the year of the data you wish to consolidate:", Type:=1)
If Result = "False" Then Exit Sub

StartDate = DateSerial(Result, 1, 1)
EndDate = DateSerial(Result, 12, 31)

ChDir "C:\Passage\Bosse"
Workbooks.Open "c:\passage\Bosse\Summering2006.xls"
ChDir "C:\Passage"

For i = StartDate To EndDate
filnamn = Format(i, "yymmdd") & ".xls"

Workbooks.Open filnamn

' Copy the information for entrance

Windows(filnamn).Activate
Range("B2:B16").Select
Selection.Copy

' Paste the information for entrance

Windows("Summering2006.xls").Activate
Sheets("Huvudentre").Select
Columns("A:A").Find(What:=Date -1, LookIn:=xlValues).Activate
ActiveCell.Offset(0, 2).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False_, Transpose:=True

' Copy the information for gallery 1

Windows(filnamn).Activate
Range("D216").Select
Selection.Copy

' Paste the information for entrance

Windows("Summering2006.xls").Activate
Sheets("Plan1").Select
Columns("A:A").Find(What:=Date - 1, LookIn:=xlValues).Activate
ActiveCell.Offset(0, 2).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False_, Transpose:=True

' Copy the information for gallery 3

Windows(filnamn).Activate
Range("E2:E16").Select
Selection.Copy

' Paste the information for entrance

Windows("Summering2006.xls").Activate
Sheets("Plan3").Select
Columns("A:A").Find(What:=Date - 1, LookIn:=xlValues).Activate
ActiveCell.Offset(0, 2).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False_, Transpose:=True

' Copy the information for gallery 4

Windows(filnamn).Activate
Range("F2:F16").Select
Selection.Copy

' Paste the information for entrance

Windows("Summering2006.xls").Activate
Sheets("Plan4").Select
Columns("A:A").Find(What:=Date - 1, LookIn:=xlValues).Activate
ActiveCell.Offset(0, 2).Activate
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False_, Transpose:=True

' Close the files

Workbooks(filnamn).Close
Next i

Workbooks("Summering2006.xls").Close SaveChanges:=True

ConsolidateData_Exit:

Exit Sub

Errorhandler:
Select Case Err.Number
Case 1005
'No message; just recover & go on to next file
Resume Next
Case Else
MsgBox (Err.Description)
Resume ConsolidateData_Exit
End Select

End Sub

 

[rmikesmith]

Roger,

I will take a closer look at the code that actually performs the find/copy (which I ignored previously) to see what changes are needed to make it function properly in the loop. I also see the problem with the error handler. I'm busy currently but should have something on Saturday, January 14.


Regards,
Mike

 

[Roxalia]

Hi Mike,

I sorted out the FIND question. I just added:

Dim datum As Date
...
datum = Format(i, "yyyy-mm-dd")
...

and changed:
Columns("A:A").Find(What:=Date - 1, LookIn:=xlValues).Activate

to

Columns("A:A").Find(datum, LookIn:=xlValues).Activate

Now the program loops until the last date as it should but after trying different ways with the ERROR command. But when a file is missing it paste in the same garbage string in that row.

I know that the way I copy and paste the information is not ideal, but I used the Macro-recorder for this part.

Greetings,

Roger

 

[rmikesmith]

Roger,

FYI. I'm working on incorporating your change to the Find call, fixing the error handling issue and streamlining the copy/paste section. I'll post this a little later.

Regards,
Mike

 

[rmikesmith]

Hi Roger,

I have re-vamped your code in several ways. In terms of overall structure, I have split out the code to open/copy/paste data for a single file into its own sub procedure. This sub is now called inside the loop of the YearCopy procedure. One benefit is you could easily call this secondary procedure if you only wanted to consolidate a singe day's data. I changed the error handling strategy: the code explicitly checks for the existence of the source file each time through the loop (see the FileExists function at the end of the posted code). The secondary procedure is called only if the file exists. The error handler responds to unexpected error conditions, as it should. Lastly, as you mentioned, the copy/paste routines were not ideal. Using the macro recorder is a good first start, especially to understand the objects involved and their relevant methods and properties. However, the generated code is almost always very inefficient, with multiple selections and activations of various objects. In most cases, your code does not need to select or activate the workbook elements in order to manipulate them, and those are slow operations. Look at the secondary procedure (CopyOneFile) to see how these were eliminated. I've also used a number of object variables for convenience and to make some of the code clearer. Also note the global variable declaration (wkbMaster).

Dim wkbMaster As Workbook

Sub Yearcopy()

Dim Result As Variant
Dim i As Long
Dim StartDate As Date
Dim EndDate As Date
Dim filnamn As String
Dim SourcePath As String
Dim DestPath As String


   Result = Application.InputBox(Prompt:="Enter the year of the data you wish to consolidate:", Type:=1)
   If Result = "False" Then Exit Sub
   
   StartDate = DateSerial(Result, 1, 1)
   EndDate = DateSerial(Result, 12, 31)
   
   SourcePath = "C:\Passage"
   DestPath = "C:\Passage\Bosse"
   
   Set wkbMaster = Workbooks.Open(DestPath & "\" & "Summering2006.xls")

   For i = StartDate To EndDate
     filnamn = Format(i, "yymmdd") & ".xls"
     If FileExists(SourcePath & "\" & filnamn) Then
       CopyOneFile SourcePath & "\" & filnamn, i
     End If
   Next i

   wkbMaster.Close SaveChanges:=True

ConsolidateData_Exit:
   Set wkbMaster = Nothing
   Exit Sub

Errorhandler:
   MsgBox (Err.Description)
   Resume ConsolidateData_Exit

End Sub


Sub CopyOneFile(ByVal FName As String, ByVal SrchDate As Date)
Dim wkbSource As Workbook
Dim wksDest As Worksheet
Dim Rng As Range


   Set wkbSource = Workbooks.Open(FName)
   
   With wkbSource
     ' Copy & Paste the information for entrance
     Set wksDest = wkbMaster.Sheets("Huvudentre")
     Set Rng = wksDest.Columns("A:A").Find(What:=SrchDate, LookIn:=xlValues)
     If Not Rng Is Nothing Then
       .ActiveSheet.Range("B2:B16").Copy
       Rng.Offset(0, 2).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
     End If

     ' Copy & Paste the information for gallery 1
     Set wksDest = wkbMaster.Sheets("Plan1")
     Set Rng = wksDest.Columns("A:A").Find(What:=SrchDate, LookIn:=xlValues)
     If Not Rng Is Nothing Then
       .ActiveSheet.Range("D2:D16").Copy
       Rng.Offset(0, 2).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
     End If

     ' Copy & Paste the information for gallery 3
     Set wksDest = wkbMaster.Sheets("Plan3")
     Set Rng = wksDest.Columns("A:A").Find(What:=SrchDate, LookIn:=xlValues)
     If Not Rng Is Nothing Then
       .ActiveSheet.Range("E2:E16").Copy
       Rng.Offset(0, 2).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
     End If

     ' Copy & Paste the information for gallery 4
     Set wksDest = wkbMaster.Sheets("Plan4")
     Set Rng = wksDest.Columns("A:A").Find(What:=SrchDate, LookIn:=xlValues)
     If Not Rng Is Nothing Then
       .ActiveSheet.Range("F2:F16").Copy
       Rng.Offset(0, 2).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
     End If
     
   End With

' Close the workbook
   wkbSource.Close

End Sub


Function FileExists(ByVal FName As String) As Boolean
   FileExists = (Dir(FName) <> "")
End Function

This code has been tested using mocked-up workbooks and appears to run OK. If you want to be safe, you can copy this into a new module and export then delet the existing code module while you test it.


Regards,
Mike

 

[Roxalia]

Thank you Mike,

It works like a charm and I'm going to spend this swedish night learning some new things. You enlightened my VBA world.

Best regards,

Roger
A humble servant to the global VBA community