The whole code is as follows:

'32-bit API declarations (BT)
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

Public Type BROWSEINFO
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

Sub Commissioner()

'Switch off screen flashing

Application.ScreenUpdating = False

'Turn off auto calculation

With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

'Request the user to select the folder containing the latest commissioner data

Msg = "Select the folder containing the latest COMMISSIONER data"
DDirectory = GetDirectory(Msg)
If DDirectory = "" Then Exit Sub
If Right(DDirectory, 1) < "\" Then DDirectory = DDirectory & "\"

a = MsgBox(Prompt:=DDirectory, Buttons:=vbOKOnly)

'Open each text file and save it as an excel file

ChDir DDirectory

Set fso = CreateObject("Scripting.FileSystemObject").GetFold er(DDirectory)
For Each file In fso.Files
If file.Type = "Text Document" Then
With file

Workbooks.OpenText Filename:=file.Name _
, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1),
Array(7, 1), Array(8, 1), _
Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1),
Array(14, 1), Array(15, 1), _
Array(16, 1), Array(17, 1), Array(18, 1)), TrailingMinusNumbers:=True

ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Name & ".xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

ActiveWorkbook.Close

End With
End If
Next
Set fso = Nothing

'Unhide all worksheets

Sheets("6.1 ReportDownload").Visible = True
Sheets("6.2 ReportDownload").Visible = True
Sheets("7.1 ReportDownload").Visible = True
Sheets("7.2 ReportDownload").Visible = True
Sheets("7.7 ReportDownload").Visible = True
Sheets("7.8 ReportDownload").Visible = True
Sheets("8.1 ReportDownload").Visible = True
Sheets("8.2 ReportDownload").Visible = True
Sheets("8.7 ReportDownload").Visible = True
Sheets("9.1 ReportDownload").Visible = True
Sheets("9.2 ReportDownload").Visible = True
Sheets("10.1 ReportDownload").Visible = True
Sheets("10.2 ReportDownload").Visible = True

'Open each Excel file and copy it into the model

Dim strWSName As String
Dim ws As Worksheet

done = False

Windows("Cancer monitoring (Commissioner).xls").Activate

For Each ws In ActiveWorkbook.Worksheets

If Left(ws.Name, 4) = Left(wbdatafile.Name, 4) Then

wbdatafile.Open
Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy

ThisWorkbook.Activate

strWSName = wbdatafile.Name
If SheetExists = True Then
Worksheets(strWSName).Activate

Range("B65536").End(xlUp).Offset(1, -1).Select
ActiveSheet.Paste
Range("B65536").End(xlUp).Offset(1, -1).Select

wbdatafile.Activate
ActiveWorkbook.Close

done = True

Exit For
End If
End If

Next








'Rehide all worksheets

Sheets("6.1 ReportDownload").Visible = False
Sheets("6.2 ReportDownload").Visible = False
Sheets("7.1 ReportDownload").Visible = False
Sheets("7.2 ReportDownload").Visible = False
Sheets("7.7 ReportDownload").Visible = False
Sheets("7.8 ReportDownload").Visible = False
Sheets("8.1 ReportDownload").Visible = False
Sheets("8.2 ReportDownload").Visible = False
Sheets("8.7 ReportDownload").Visible = False
Sheets("9.1 ReportDownload").Visible = False
Sheets("9.2 ReportDownload").Visible = False
Sheets("10.1 ReportDownload").Visible = False
Sheets("10.2 ReportDownload").Visible = False

'Switch on auto calculation

With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
ActiveWorkbook.PrecisionAsDisplayed = False

'Switch on screen flashing

Application.ScreenUpdating = True

End Sub
'More BT declarations
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 = 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






"sali" wrote:

"BoRed79" je napisao u poruci interesnoj
...

the problem - however - I am not really sure where to start in modifying
my

if it helps, try posting here the whole code, like copy/paste


.