Help on complicated VBA code

S

superfb

Active Member
Joined
Oct 5, 2011
Messages
251
Office Version
  1. 2007
Platform
  1. Windows
Hi all.

i have a beast of a macro/VBA code where i have tried to dissect it. The purpose of this macro is once you highlight the input folder, It extracts data according to the spreadsheet you select (this s/s are allocated in folders according to years). By this the VBA code picks up the folder name and picks out the year and puts this into table. In essence helping to create a time series of data. But the issue i have it misses 2005 and it doesnt save the file once created as it says memory used is too much please use excel x64.

The folders are listed as
199720052012
199820062013
19992006s42014
200020072015
20012008
2016​
20022009
2017​
20032010
2018​
20042011
2019​
2004s12011 soc00
2020​


VBA Code: 
Private Sub CreateTimeseries_Click()
'macro starts here matches the paremeters tab to understand end users requirements
'Notes down file name, tabs and variables then check its on paremeters tab. 13 on B2, the code adds 3 to this and then loops to find each variable and to match the columns
Dim FileName, SheetName, VariableName, VariableCol As String
Dim Count, LastRow As Integer

FileName = Sheets("Start").Cells(2, 1).value 'filename at cell A2
SheetName = Sheets("Start").Cells(3, 1).value   'Selecting tabs at cell A3
VariableName = Sheets("Start").Cells(4, 1).value 'Variables you have selected A4
VariableCol = 0
LastRow = 3 + Sheets("Parameters").Cells(2, 2).value 'parameters sheets links to 13 and then adds 3
For Count = 4 To LastRow 'ends up doing a count 4 to 16 to determine what variables you selected matches the paremeters
    If VariableName = Sheets("Parameters").Cells(Count, 2).value Then 'does the variable match the column in parameters when it matches goes to next criteria
        VariableCol = Sheets("Parameters").Cells(Count, 3).value 'if matches the number of columns in number in "col" grab the column number
        Exit For
    End If
Next Count
If FileName <> "" And SheetName <> "" And VariableName <> "" And VariableCol <> 0 Then 'double checking every critera is filled
    Module1.CreateTimeseries FileName, SheetName, VariableName, VariableCol 'opens up module
End If
End Sub

VBA Code: 
Function Initialise() As Boolean
' Sets global constants.
' Values are mainly read from the parameters sheet, although some come from the Start sheet
' Folder names depend on the location of this workbook.
Dim Text As String
Dim Count, Pos, LastPos1, LastPos2 As Integer

Initialise = False
Application.ScreenUpdating = False

' gets the path for the file name then adds "\"
'programme file is the name of the macro workbook

ThisFolder = ActiveWorkbook.path 'The file location of the macro you are using
ThisFolder = ThisFolder & "\" 'adds a baackslash to the file location of the macro
ProgramFile = ActiveWorkbook.Name 'name of the macro file you are using


'****input folder details*******

'Folder name containing the files to be imported
'Input input folder from user if folder not given in cell J15 of Start sheet

InputFolder = Sheets("Start").Range("C25").value 'value in the inputfolder
If InputFolder = Empty Then 'if not empty this ends, otherwise you are prompted again to enter input folder
    InputFolder = GetDirectory
    If InputFolder = "" Then Exit Function
    Sheets("Start").Range("C25").value = InputFolder
End If
'Append \ on to workfolder name if it does not already have a \
InputFolder = InputFolder & IIf("\" = Right(InputFolder, 1), "", "\")
'*********************************************************************************************

'****Output folder details*******

'Folder name to where files are to be output
'Output Output folder from user if folder not given in cell J15 of Start sheet

OutputFolder = Sheets("Start").Range("C28").value 'Grabs the output folder
If OutputFolder = Empty Then 'if nothing there you get prompted to eneter details
    OutputFolder = GetDirectory
    If OutputFolder = "" Then Exit Function
    Sheets("Start").Range("C28").value = OutputFolder
End If

'Append \ on to workfolder name if it does not already have a \

OutputFolder = OutputFolder & IIf("\" = Right(OutputFolder, 1), "", "\") 'adds a \ to the output file

'*************************************************************************************************
LowerYear = Sheets("Start").Range("C25").value 'this is equal to the input file name?
'*********************************************************************************************


'Extract year from filename
' finds the number of times "\" appears in the text and loops it
LastPos1 = 1
LastPos2 = 1
For Count = 1 To 20
    Pos = InStr(LastPos1 + 1, LowerYear, "\") '
    If Pos = 0 Then Exit For
    LastPos2 = LastPos1
    LastPos1 = Pos
Next Count
LowerYear = Mid(LowerYear, LastPos2 + 1, 4) 'extracts the year from file name by finding the "\" position in the filename
UpperYear = Sheets("Parameters").Range("D4").value 'links to "last year" in parameter tab
FirstRow = Sheets("Parameters").Range("E4").value   'links to "First Row" in parameter tab D4 cell
FolderExtension2004 = Sheets("Parameters").Range("F4").value 'links to "Folder Extension" in parameter tab -S1
FolderExtension2006 = Sheets("Parameters").Range("F5").value  'links to "Folder Extension" in parameter tab - S4
FolderExtension2011 = Sheets("Parameters").Range("F6").value 'links to "Folder Extension" in parameter tab -sOC (2010)
KeyRow = Sheets("Parameters").Range("G4").value 'The row (G4) and column (G5) of the cell that contains the upper left 6 ----------- not too sure about the 6,9,12
KeyCol = Sheets("Parameters").Range("G5").value  'corner of the table of key information. G6 contains the number of rows in the key table. 9
KeyLength = Sheets("Parameters").Range("G6").value '12
RemoveLinks = False
If "YES" = UCase(Sheets("Parameters").Range("H4").value) Then
    RemoveLinks = True
End If
MaxRows = Sheets("Parameters").Range("I4").value ',AX ROWS = 1000

Initialise = True

VBA Code: 
Sub CreateTimeseries(FileName, SheetName, VariableName, VariableCol)
Dim Count, Year, Row, Col, LastRow, Pos, HeadingColour, TitleColour, AddYear  As Integer
Dim CellColour, CellPattern, CellIndex As Integer
Dim Name, LowerYearText, Folder, Text As String

'goes to intialise function
If Not Initialise Then Exit Sub


Sheets("Output").Select 'once the variables have been determined add file year been extracted from below it comes to this point
Cells.Select ' highlights everything and deletes it
Selection.Delete Shift:=xlUp
Range("A1").Select 'deletes everything and selects cell A1
On Error GoTo Error1
Workbooks.Open FileName:=InputFolder & "\" & FileName 'OPENS THE DESIGNATED WORKBOOK
On Error GoTo 0
Sheets(SheetName).Select 'SELECTS THE SHEET YOU CHOSE
Cells(MaxRows, 3).Select 'ROW 10000 col c
Selection.End(xlUp).Select 'goes up to last data in col c
LastRow = ActiveCell.Row
LowerYearText = Format(LowerYear, "0")

' Copy across heading rows from table file to output sheet

TitleColour = Cells(1, 1).Interior.ColorIndex
HeadingColour = Cells(FirstRow - 1, 1).Interior.ColorIndex
For Count = 1 To FirstRow - 1
    Windows(FileName).Activate
    Col = Columns("A:A").ColumnWidth
    Cells(Count, 1).Copy
    Windows(ProgramFile).Activate
    Columns("A:A").ColumnWidth = Col
    Cells(Count, 1).Select
    ActiveSheet.Paste 'code above copies A1 over
    
    Windows(FileName).Activate ' go back to the designated
    Col = Columns("B:B").ColumnWidth 'copyover col b
    Cells(Count, 2).Copy 'the count comes from above
    Windows(ProgramFile).Activate
    Columns("B:B").ColumnWidth = Col
    Cells(Count, 2).Select
    ActiveSheet.Paste
Next Count
Windows(FileName).Close


'***************adds 1,2,3 years*************************************
If LowerYear < 2004 Then
    If UpperYear >= 2004 And UpperYear < 2006 Then
        AddYear = 1
    ElseIf UpperYear >= 2006 And UpperYear < 2011 Then
        AddYear = 2
    ElseIf UpperYear >= 2011 Then
        AddYear = 3
    Else
        AddYear = 0
    End If
ElseIf LowerYear >= 2004 And LowerYear < 2006 Then
    If UpperYear >= 2006 And UpperYear < 2011 Then
        AddYear = 1
    ElseIf UpperYear >= 2011 Then
        AddYear = 2
    Else
        AddYear = 0
    End If
ElseIf LowerYear >= 2006 And LowerYear < 2011 Then
    If UpperYear >= 2011 Then
        AddYear = 1
    Else
        AddYear = 0
    End If
Else
    AddYear = 0
End If
    
  '****************this code adds the subsequent years*************************************************
    
For Count = LowerYear To UpperYear + AddYear 'first year and last year then adds 1,2, or 3 depending what years fall on the above if statement?
    Col = 3 + Count - LowerYear
    Year = Count
    Range(Cells(1, Col), Cells(2, Col)).Interior.ColorIndex = TitleColour
    Cells(2, Col).Borders(xlEdgeBottom).LineStyle = xlContinuous
    'Cells(2, Col).Borders(xlEdgeBottom).Weight = xlSolid
    Cells(2, Col).Borders(xlEdgeBottom).Weight = xlMedium
    Cells(2, Col).Borders(xlEdgeBottom).ColorIndex = xlAutomatic
    Range(Cells(3, Col), Cells(FirstRow - 1, Col)).Interior.ColorIndex = HeadingColour
    Cells(FirstRow - 1, Col).Borders(xlEdgeBottom).LineStyle = xlContinuous
    Cells(FirstRow - 1, Col).Borders(xlEdgeBottom).Weight = xlThin

'******************If 2004,2006, amd 2011 adds "**"******************************************


    If Count >= 2004 Then
        ' There are two sets of data for 2004, 2006 and 2011 ---------- this code must add the extra column for 2004,2006.2011
        If Count = 2004 Then
            Cells(FirstRow - 1, Col) = Year & "**"
        ElseIf Count = 2006 Then
            Cells(FirstRow - 1, Col) = Year & "**"
        ElseIf Count = 2011 Then
            Cells(FirstRow - 1, Col) = Year & "**"
        Else
            Year = Count - 1
            Cells(FirstRow - 1, Col) = Year
        End If
    Else
        Cells(FirstRow - 1, Col) = Year
    End If
    Cells(FirstRow - 1, Col).HorizontalAlignment = xlRight
    
    
    '****displays messages***********************
    
    Text = "Processing year: " & Year & "  "
    Display_Message Text                      'displays status on bar
    
    
    '*******finding year in filename****************
    
    Pos = InStr(1, FileName, LowerYearText) 'find year in filename
    Name = Left(FileName, Pos - 1) & Format(Year, "0") & Right(FileName, 1 + Len(FileName) - (Pos + Len(LowerYearText)))
    Pos = InStr(1, InputFolder, LowerYearText)
    If Count = 2004 Then
        Folder = Left(InputFolder, Pos - 1) & Format(Year, "0") & FolderExtension2004 & Right(InputFolder, 1 + Len(InputFolder) - (Pos + Len(LowerYearText)))
    ElseIf Count = 2006 Then
        Folder = Left(InputFolder, Pos - 1) & Format(Year, "0") & FolderExtension2006 & Right(InputFolder, 1 + Len(InputFolder) - (Pos + Len(LowerYearText)))
    ElseIf Count = 2011 Then
        Folder = Left(InputFolder, Pos - 1) & Format(Year, "0") & FolderExtension2011 & Right(InputFolder, 1 + Len(InputFolder) - (Pos + Len(LowerYearText)))
    Else
        Folder = Left(InputFolder, Pos - 1) & Format(Year, "0") & Right(InputFolder, 1 + Len(InputFolder) - (Pos + Len(LowerYearText)))
    End If
    On Error GoTo Error2
    Workbooks.Open FileName:=Folder & "\" & Name
    GoTo Continue1

'***opens up the file ^^^************

Error2:
    On Error GoTo 0
    RetVal = MsgBox("Unable to open table: " & Name & vbCrLf & vbCrLf & _
            "Continue with the next year?", vbYesNo)
    If RetVal = vbNo Then
        Display_Message ""
        Exit Sub
    End If
    On Error GoTo 0
    GoTo Continue2

'***********opens the file and then copies over the data*******************************************

Continue1:
    Sheets(SheetName).Select
    For Row = FirstRow To LastRow
        Application.StatusBar = Text & Format(100 * ((Row - 1) / LastRow), "0") & "%"
        If 0 = Count - LowerYear Then
            Windows(Name).Activate
            Range(Cells(Row, 1), Cells(Row, 2)).Copy
            Windows(ProgramFile).Activate
            Cells(Row, 1).Select
            ActiveSheet.Paste
        End If
        Windows(Name).Activate
        CellColour = Cells(Row, Val(VariableCol)).Interior.ColorIndex
        CellPattern = Cells(Row, Val(VariableCol)).Interior.Pattern
        CellIndex = Cells(Row, Val(VariableCol)).Interior.PatternColorIndex
        Windows(ProgramFile).Activate
        Cells(Row, Col).Interior.ColorIndex = CellColour
        Cells(Row, Col).Interior.Pattern = CellPattern
        Cells(Row, Col).Interior.PatternColorIndex = CellIndex
        Cells(Row, Col).FormulaR1C1 = "='[" & Name & "]" & SheetName & "'!R" & Row & "C" & VariableCol
    Next Row
    If RemoveLinks Then
        Range(Cells(FirstRow, Col), Cells(LastRow, Col)).Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=False
    End If
    '*************^^^^^^^^^^^^copies over the data and paste value special^^^^^^^^^**************************
    
    
    If Count = UpperYear + AddYear Then
        Windows(Name).Activate
        Range(Cells(KeyRow, KeyCol), Cells(KeyRow + KeyLength - 1, KeyCol)).Copy
        Windows(ProgramFile).Activate
        Cells(KeyRow, Col + 2).Select
        ActiveSheet.Paste
        Columns(Col + 2).ColumnWidth = 21.3
    End If
    Windows(Name).Close


Continue2:

Next Count

'**** goes to the next one**************
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
the error message when it tries to save the workbook is

"There isnt enough memory to complete this action. Try using less data or closing other applications. To increase memory availability consider using a 64-bit version of Microsoft excel".
 
Upvote 0
VBA Code: 
If Count >= 2004 Then
        ' There are two sets of data for 2004, 2006 and 2011 ---------- this code must add the extra column for 2004,2006.2011
        If Count = 2004 Then
            Cells(FirstRow - 1, Col) = Year & "**"
        ElseIf Count = 2006 Then
            Cells(FirstRow - 1, Col) = Year & "**"
        ElseIf Count = 2011 Then
            Cells(FirstRow - 1, Col) = Year & "**"
        Else
            Year = Count - 1                      'once the year is above 2004 it minus one year
            Cells(FirstRow - 1, Col) = Year
        End If
    Else

I think this is where the issue starts - when the count is 2005, the following code is executed and minus one year,

VBA Code: 
   Year = Count - 1                      'once the year is above 2004 it minus one year
            Cells(FirstRow - 1, Col) = Year

When it goes to the next count it is 2006 therefore he following code gets executed

VBA Code: 
ElseIf Count = 2006 Then
            Cells(FirstRow - 1, Col) = Year & "**"

Hence when 2005 gets missed as it doesnt get subtracted........any ideas how i can rectify this?
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
VBA code driving me insane!
Replies
3
Views
1K
Joe4
Joe4
H
  • Question
VBA split file based and send splitted file in separate emails
Replies
0
Views
153
harmless92
H
H
  • Question
Macro to Extract Duplicate Items on Shet "Summary within sub-folders
Replies
1
Views
314
howard
H
C
  • Question
Copy and paste data through multiple workbooks
Replies
2
Views
203
CDaviess
C
M
  • Question
Excel Macro
Replies
0
Views
588
msmb
M

Forum statistics

Threads
1,214,998
Messages
6,122,643
Members
449,093
Latest member
Ahmad123098

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top