VBA code driving me insane!

S

superfb

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

Line 42 is creating an error - User-defined type not defined - i have copied this code from a previous macro, and i cant see them defining this variable anywhere?

also would anyone know how i could incorporate another listbox for years (multiple years to be selected) and the data copied over as per the user requirments


VBA Code: 
Option Explicit

'These are global constants available throughtout the programme. They are usually initialised in the subroutine intialises
'Many take values from Parameters sheet. The programme does not change
' the value in these variables after they are intialised

Dim ThisFolder As String
Dim ProgramFile As String
Dim InputFolder As String
Dim OutputFolder As String
Dim WorkFile As String
Dim TableFolder As String
Dim FolderExtension2004 As String
Dim FolderExtension2006 As String
Dim FolderExtension2011 As String
Dim RetVal
Dim LowerYear As Integer
Dim UpperYear As Integer
Dim FirstRow As Integer
Dim KeyRow As Integer
Dim KeyCol As Integer
Dim KeyLength As Integer
Dim MaxRows As Integer
Dim RemoveLinks As Boolean

'Used by the dialog box that displays a change folers list
Public Type BRWOSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
End Type

'32-Bit API Declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszpath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Sub CreateTimseries(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

If Not intialise Then Exit Sub
Sheets("Output").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select

On Error GoTo Error1
Workbooks.Open FileName:=InputFolder & "\" & FileName
On Error GoTo 0
Sheets(SheetName).Select
Cells(MaxRows, 3).Select
Selection.Delete Shift:=xlUp
LastRow = ActiveCell.Row
LowerYearText = Format(LowerYear, "0")

'copy across heading rows from table file to output sheet
TitleColour = Cells(1, 1).Interior.ColorIndex
headingcolor = 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).actiavte
    Col = Columns("a:a").ColumnWidth = Col
    Cells(Count, 1).Select
    ActiveSheet.Paste
    
Windows(FileName).Activate
Columns("B:B").ColumnWidth = Col
Cells(Count, 2).Select

Windows(ProgramFile).Activate
Columns("B:B").ColumnWidth = Col
Cells(Count, 2).Select
ActiveSheet.Paste

Next Count
Windows(FileName).Close

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
For Count = LowerYear To UpperYear + AddYear
Col = 3 + Count - LowerYear

Windows(ProgramFile).Activate
Columns("B:B").ColumnWidth = Col
Cells(Count, 2).Select
ActiveSheet.Paste
Next Count
Windows(FileName).Close
    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
    For Count = LowerYear To UpperYear + AddYear
    Col = 3 + Count - LowerYear
Year = Count
Range(Cells(1, Col), Cells(2, Col)).Interior.Colorlodex = TitleColor
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 Count >= 2004 Then
'There are two sets of data for 2004, 2006 and 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
Text = "Processing year: " & Year & "."
Display_Message Text
Pos = InStr(1, FileName, 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

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 O
GoTo Continue2
Continuel:
Sheets(SheetName).Select
For Row = FirstRow To LastRow
Application.StatusBar = Text & Format(100 * ((Row - 1) / LastRow), "O") & "9"
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
        
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:=x1None, SkipBlanks:= _
    False, Transpose:=False
End If

Create Timeseries
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
Sheets("Output").Select
ActiveWindow.DisplayZeros = False
Pos -InStr(1, FileName, LowerYearText)
Name = Left(FileName, Pos - 1) & LowerYearText & "_" & Format(UpperYear, "0") & Right(FileName, 1 + Len(FileName) - (Pos + Len(LowerYearText)))
Display_Message "Saving time series file to: " & OutputFolder & SheetName & " " & VariableName & " & Name"
Sheets("Output").Copy
ActiveWorkbook.SaveAs FileName:=OutputFolder & SheetName & "" & VariableName & "" & Name, _
    FileFormat:=xlNormal, Password:="", WriteResPassword:="*", _
    ReadOnlyRecommended:=False, CreateBackup:=False

Sheets("Output").Name = VariableName
Cells(4, 3).value = VariableName
Range(Cells(4, 3), Cells(4, 4 + (UpperYear - LowerYear))).Select
With Selection
HorizontalAlignment = xlCenter
VerticalAlignment = xlBottom
.WrapText = False
Orientation = 0
.ShrinkToFit = False
.MergeCells -True
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = x1None
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone

Range(Cells(LastRow, 3), Cells(LastRow, 4 + (UpperYear - LowerYear))).Select
With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
End With

Range("A1").Select
Create_Growth Sheet
ActiveWorkbook.Close savechanges:=True
Sheets("Output").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("Start").Select
Cells(18, 1).value = OutputFolder & SheetName & "" & VariableName & "" & Name
Display_Message
Exit Sub
Errorl:
MsgBox "Unable to open first table: " & InputFolder & "\" & FileName
Display_Message ""
End Sub
Sub OpenTSFile()
Dim FileName, VariableName, Name, LowerYearText, Folder, Text As String
Dim Pos As Integer
FileName = Sheets("Start").Cells(18, 1).value

FileName -Sheets("Start").Cells(18, 1).value
If "" = FileName Then
MsgBox "No timeseries name found in cell A18 of the Start sheet.", vbCritical
Exit Sub
End If
On Error GoTo Error2
Workbooks.Open FileName:=FileName
On Error GoTo 0
Exit Sub
Error2:
MagBox "Unable to open file:= & FileName, vbcritical"
Display_Message ""

End Sub
Sub Create()
Growth Sheet()
Dim Lastcol, Count As Integer
Dim Name As String

Sheets(1).Select
Name = Sheets(1).Name
Sheets(1).Copy After:=Sheets(1)
Sheets(2).Select
Sheets(2).Name = "Growth"
Cells(6, 3).Select  'Delete first column of data, no data to calculate growth rate on
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("d6").Select
ActiveCell.FormulaR1C1 = _
    "=If (AND (" & Name & "!RC>0," & Name & "!RC[-1]>0), 100 * (" & Name & "!RC/" & Name & "!RC[-1]-1),"""")"
Selection.Number Format - "0.0"
Cells(5, 40).Select
Selection.End(xlToLeft).Select
Lastcol -ActiveCell.Column
Range("06").Select
Selection.Copy
Range(Cells(6, 4), Cells(6, Lastcol)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
For Count = 4 To Lastcol
If Cells(5, Count).value - "2004" Then
'Delete extra 2004 column as there are two 2004 results
Cells(6, Count).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
ElseIf Cells(5, Count).value = "2006" Then

ElseIf Cells(5, Count).value = "2006" Then
'Delete extra 2006 column as there are two 2006 results
Cells(6, Count).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
ElseIf Cells(5, Count).value = "2011" Then
'Delete extra 2011 column as there are two 2011 results
Cells(6, Count).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
End If
Next Count
Range("A1").Select
End Sub
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 As Integer, Pos, LastPosi, LastPos2 As Integer
Initialise = False
Application.ScreenUpdating -False
ThisFolder -ActiveWorkbook.path
ThisFolder = ThisFolder & ""
ProgramFile -ActiveWorkbook.Name
'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
If InputFolder = Empty Then
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), "", "\")
'Folder name to where files are to be output
'Output Output folder from user if folder not given in cell J15 of Start sheet
Output Fold - Sheets("Start").Range("C26").value
If OutputFolder = Empty Then
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), "", "\")
LowerYear -Sheets("Start").Range("C25").value
'Extract year from filename
Last Posl - 1
Last Pos2 = 1
For Count = 1 To 20
Pos = InStr(LastPoul + 1, LowerYear, "")
If Poy = 0 Then Exit For
LastPos2 = LastPosl
LastPosl = Pos
Next Count
LowerYear = Mid(LowerYear, LastPos2 + 1, 4)
UpperYear -Sheets("Parameters").Range("D4")

FirstRow = Sheets("Parameters").Range("04").value
FolderExtension 2004 = Sheets("Parameters").Range("F4").value
FolderExtension 2006 = Sheets("Parameters").Range("F5").value
FolderExtension 2011 = Sheets("Parameters").Range("F6").value

KeyRow = Sheets("Parameters").Range("G4").value
KeyCol = Sheets("Parameters").Range("G5").value
KeyLength = Sheets("Parameters").Range("G6").value
RemoveLinks = False

If "YES" = UCase(Sheets("Parameters").Range("H4").value) Then
RemoveLinks = True
End If
MaxRows = Sheets("Parameters").Range("I4").value
Initialise = True
End Function

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, Pos As Integer
'Root Folder - Desktop
bInfo.pidlRoot = 0&
'Title in the dialog

If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg

End If

'Type of directory to return
bInfo.ulFlags = &H1

'Display the dialog
x = SHBrowseForFolder(bInfo)

'Parse the result
path = Spaces(512)
r -SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
    Pos -InStr(path, Chr$(0))
    GetDirectory -Left(path, Pos - 1)
Else

GetDirectory = ""

End If
End Function
Sub Display_Message(Message As String)
'Displayeg a message on the status bar at the bottom of the screen.
'Text = the message to display. If blank then the status bar will be reset to the default.
Application.ScreenUpdating = False
If Len(Message) > 0 Then
Application.StatusBar -Message & " Please wait....."
Else
Application.StatusBar -False
End If
End Sub

Sub TEST()

Dim value

value = Cells(298, 4).value
If value = "" Then
Stop
End If

End Sub
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Are you using a 64 bit computer?
I found an article that says that command is not compatible with a 64 bit computer.
The article also has a workaround. See: VBA Macros - shell32.dll
 
Upvote 0
Apologies the earlier code was filled with errors - also found a code for 62bit but the macro isnt working overall......

VBA Code: 
Option Explicit

'These are global constants available throughtout the programme. They are usually initialised in the subroutine intialises
'Many take values from Parameters sheet. The programme does not change
' the value in these variables after they are intialised

Dim ThisFolder As String
Dim ProgramFile As String
Dim InputFolder As String
Dim OutputFolder As String
Dim WorkFile As String
Dim TableFolder As String
Dim FolderExtension2004 As String
Dim FolderExtension2006 As String
Dim FolderExtension2011 As String
Dim RetVal
Dim LowerYear As Integer
Dim UpperYear As Integer
Dim FirstRow As Integer
Dim KeyRow As Integer
Dim KeyCol As Integer
Dim KeyLength As Integer
Dim MaxRows As Integer
Dim RemoveLinks As Boolean

'Used by the dialog box that displays a change folers list
Public Type BRWOSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
End Type




'Optionflags des ShellGetFolder-Dialogs
Enum vbShellGetFolderFlags
  BIF_RETURNONLYFSDIRS = &H1
  BIF_DONTGOBELOWDOMAIN = &H2
  BIF_STATUSTEXT = &H4
  BIF_RETURNFSANCESTORS = &H8
  BIF_EDITBOX = &H10
  BIF_VALIDATE = &H20
  BIF_NEWDIALOGSTYLE = &H40
  BIF_BROWSEINCLUDEURLS = &H80
  BIF_BROWSEFORCOMPUTER = &H1000
  BIF_BROWSEFORPRINTER = &H2000
  BIF_BROWSEINCLUDEFILES = &H4000
  BIF_SHAREABLE = &H8000
  BIF_SHOWALLOBJECTS = &H8
End Enum

Const BIF_DefaultOptions = BIF_EDITBOX Or BIF_VALIDATE Or BIF_SHOWALLOBJECTS Or BIF_STATUSTEXT Or BIF_NEWDIALOGSTYLE
Const BIF_BrowseFolder = BIF_RETURNONLYFSDIRS Or BIF_DefaultOptions
Private Const CSIDL_PERSONAL = &H5 'Eigene Dateien

Sub Example_ShellGetFolder()
  Debug.Print ShellGetFolder(CSIDL_PERSONAL, "Select a folder", BIF_BrowseFolder)
End Sub

Function ShellGetFolder( _
    Optional RootPath As Variant = CSIDL_PERSONAL, _
    Optional Caption As String = "", _
    Optional Options As vbShellGetFolderFlags = BIF_DefaultOptions) As String
  'http://msdn.microsoft.com/en-us/library/windows/desktop/bb774065(v=vs.85).aspx
  'RootPath kann ein String oder CSIDL-Konstante sein
  Dim objShell As Object, objBrowse As Object

  On Error Resume Next
  Set objShell = CreateObject("Shell.Application")
  'Dialog starten und RootPath zurückgeben
  If IsNumeric(RootPath) Then
    'Anfangspfad als Konstante
    Set objBrowse = objShell.BrowseForFolder(&H0, Caption, Options, CLng(RootPath))
  Else
    'Anfangspfad als String
    Set objBrowse = objShell.BrowseForFolder(&H0, Caption, Options, RootPath & Chr(0))
  End If
  ShellGetFolder = objBrowse.Self.path
End Function

'32-Bit API Declarations
'Declare Function SHGetPathFromIDList Lib "shell32.dll" _
'Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszpath As String) As Long

'Declare Function SHBrowseForFolder Lib "shell32.dll" _
'Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Sub CreateTimseries(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

If Not Initialise Then Exit Sub
Sheets("Output").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select

On Error GoTo Errorl
Workbooks.Open FileName:=InputFolder & "\" & FileName
On Error GoTo 0
Sheets(SheetName).Select
Cells(MaxRows, 3).Select
Selection.Delete Shift:=xlUp
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).actiavte
    Col = Columns("a:a").ColumnWidth = Col
    Cells(Count, 1).Select
    ActiveSheet.Paste
    
Windows(FileName).Activate
Columns("B:B").ColumnWidth = Col
Cells(Count, 2).Select

Windows(ProgramFile).Activate
Columns("B:B").ColumnWidth = Col
Cells(Count, 2).Select
ActiveSheet.Paste

Next Count
Windows(FileName).Close

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
For Count = LowerYear To UpperYear + AddYear
Col = 3 + Count - LowerYear

Windows(ProgramFile).Activate
Columns("B:B").ColumnWidth = Col
Cells(Count, 2).Select
ActiveSheet.Paste
Next Count
Windows(FileName).Close
    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
For Count = LowerYear To UpperYear + AddYear
    Col = 3 + Count - LowerYear

Year = Count
Range(Cells(1, Col), Cells(2, Col)).Interior.Colorlodex = 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 Count >= 2004 Then
'There are two sets of data for 2004, 2006 and 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
Text = "Processing year: " & Year & "."
Display_Message Text
Pos = InStr(1, FileName, 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

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

Continue1:
Sheets(SheetName).Select
For Row = FirstRow To LastRow
Application.StatusBar = Text & Format(100 * ((Row - 1) / LastRow), "O") & "9"
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


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
Sheets("Output").Select
ActiveWindow.DisplayZeros = False
Pos = InStr(1, FileName, LowerYearText)
Name = Left(FileName, Pos - 1) & LowerYearText & "_" & Format(UpperYear, "0") & Right(FileName, 1 + Len(FileName) - (Pos + Len(LowerYearText)))
Display_Message "Saving time series file to: " & OutputFolder & SheetName & " " & VariableName & " & Name"
Sheets("Output").Copy
ActiveWorkbook.SaveAs FileName:=OutputFolder & SheetName & "" & VariableName & "" & Name, _
    FileFormat:=xlNormal, Password:="", WriteResPassword:="*", _
    ReadOnlyRecommended:=False, CreateBackup:=False

Sheets("Output").Name = VariableName
Cells(4, 3).value = VariableName
Range(Cells(4, 3), Cells(4, 4 + (UpperYear - LowerYear))).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells -True
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone

Range(Cells(LastRow, 3), Cells(LastRow, 4 + (UpperYear - LowerYear))).Select
With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
End With

Range("A1").Select
Create_Growth_Sheet
ActiveWorkbook.Close savechanges:=True

Sheets("Output").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("Start").Select
Cells(18, 1).value = OutputFolder & SheetName & "" & VariableName & "" & Name
Display_Message ""
Exit Sub

Errorl:
MsgBox "Unable to open first table: " & InputFolder & "\" & FileName
Display_Message ""
End Sub
Sub OpenTSFile()
Dim FileName, VariableName, Name, LowerYearText, Folder, Text As String
Dim Pos As Integer
FileName = Sheets("Start").Cells(18, 1).value

FileName = Sheets("Start").Cells(18, 1).value
If "" = FileName Then
MsgBox "No timeseries name found in cell A18 of the Start sheet.", vbCritical
Exit Sub
End If
On Error GoTo Error2
Workbooks.Open FileName:=FileName
On Error GoTo 0
Exit Sub
Error2:
MsgBox "Unable to open file:= & FileName, vbcritical"
Display_Message ""

End Sub
Sub Create_Growth_Sheet()
Dim Lastcol, Count As Integer
Dim Name As String

Sheets(1).Select
Name = Sheets(1).Name
Sheets(1).Copy After:=Sheets(1)
Sheets(2).Select
Sheets(2).Name = "Growth"
Cells(6, 3).Select  'Delete first column of data, no data to calculate growth rate on
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("d6").Select
ActiveCell.FormulaR1C1 = _
    "=If (AND (" & Name & "!RC>0," & Name & "!RC[-1]>0), 100 * (" & Name & "!RC/" & Name & "!RC[-1]-1),"""")"
Selection.NumberFormat = "0.0"
Cells(5, 40).Select
Selection.End(xlToLeft).Select
Lastcol = ActiveCell.Column
Range("06").Select
Selection.Copy
Range(Cells(6, 4), Cells(6, Lastcol)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
For Count = 4 To Lastcol
If Cells(5, Count).value - "2004" Then
'Delete extra 2004 column as there are two 2004 results
Cells(6, Count).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
ElseIf Cells(5, Count).value = "2006" Then

ElseIf Cells(5, Count).value = "2006" Then
'Delete extra 2006 column as there are two 2006 results
Cells(6, Count).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
ElseIf Cells(5, Count).value = "2011" Then
'Delete extra 2011 column as there are two 2011 results
Cells(6, Count).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
End If
Next Count
Range("A1").Select
End Sub
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 As Integer, Pos, LastPos1, LastPos2 As Integer
Initialise = False
Application.ScreenUpdating = False
ThisFolder = ActiveWorkbook.path
ThisFolder = ThisFolder & ""
ProgramFile = ActiveWorkbook.Name
'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
If InputFolder = Empty Then
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), "", "\")
'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("C26").value
If OutputFolder = Empty Then
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), "", "\")
LowerYear = Sheets("Start").Range("C25").value
'Extract year from filename
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)
UpperYear = Sheets("Parameters").Range("D4")

FirstRow = Sheets("Parameters").Range("D4").value
FolderExtension2004 = Sheets("Parameters").Range("F4").value
FolderExtension2006 = Sheets("Parameters").Range("F5").value
FolderExtension2011 = Sheets("Parameters").Range("F6").value

KeyRow = Sheets("Parameters").Range("G4").value
KeyCol = Sheets("Parameters").Range("G5").value
KeyLength = Sheets("Parameters").Range("G6").value
RemoveLinks = False

If "YES" = UCase(Sheets("Parameters").Range("H4").value) Then
RemoveLinks = True
End If
MaxRows = Sheets("Parameters").Range("I4").value
Initialise = True
End Function

Function GetDirectory(Optional Msg) As String
Dim bInfo As BRWOSEINFO
Dim path As String
Dim r As Long, x As Long, Pos As Integer
'Root Folder - Desktop
bInfo.pidlRoot = 0&
'Title in the dialog

If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg

End If

'Type of directory to return
bInfo.ulFlags = &H1

'Display the dialog
'x = SHBrowseForFolder(bInfo)

'Parse the result
path = Space$(512)
'r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
    Pos = InStr(path, Chr$(0))
    GetDirectory = Left(path, Pos - 1)
Else

GetDirectory = ""

End If
End Function
Sub Display_Message(Message As String)
'Displayeg a message on the status bar at the bottom of the screen.
'Text = the message to display. If blank then the status bar will be reset to the default.
Application.ScreenUpdating = False
If Len(Message) > 0 Then
Application.StatusBar = Message & " Please wait....."
Else
Application.StatusBar = False
End If
End Sub

Sub TEST()

Dim value

value = Cells(298, 4).value
If value = "" Then
Stop
End If

End Sub
 
Upvote 0
That seems like a totally unrelated question to your original post, which was in regards to one particular line of code and the error message you were getting.

So if you have other questions about your code, it would be best to post them in a new thread. However, in order for someone to help you, you really should provide more informtion such as:
1. An example of what your data looks like
2. An explanation of exactly what it is you are trying to do
3. An example of your expected output

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Help on complicated VBA code
Replies
3
Views
751
superfb
S
P
  • Solved
Select Case in VBA
Replies
3
Views
655
rollis13
rollis13
R
  • Question Question
Compose Email VBA Help
Replies
1
Views
50
Logit
Logit
L
  • Question Question
Sending Email with Table in Body
Replies
3
Views
610
Domenic
D
D
  • Question Question
VBA Coding for adding Pivot Table with changing data table
Replies
6
Views
192
darmst24
D

Forum statistics

Threads
1,223,888
Messages
6,175,207
Members
452,618
Latest member
Tam84

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