Matching in VBA

[BoRed79]

Hi All.

Can anyone please offer some advice on where I might start to create a macro
to solve the following problem:

I have a series of xls files containing data each with a prefix of 1.1, 1.2,
1.3 etc. I want to take the data from each of these files in turn and paste
it into a master spreadsheet. In the spreadsheet there are sheets with names
that match the prefix of the downloads e.g. 1.1, 1.2, 1.3 etc.

I need to macro to match up the xls file name to the sheet name to determine
where it pastes the data.

I have code to enable it to copy and paste the data into the sheets - but
not the functionality to match the data to the correct sheets.

Can anyone point me in the right direction.

Many thanks.

Liz.

 

[sali]

Hi All.

Can anyone please offer some advice on where I might start to create a
macro
to solve the following problem:

I have a series of xls files containing data each with a prefix of 1.1,
1.2,
1.3 etc. I want to take the data from each of these files in turn and
paste
it into a master spreadsheet. In the spreadsheet there are sheets with
names
that match the prefix of the downloads e.g. 1.1, 1.2, 1.3 etc.

I need to macro to match up the xls file name to the sheet name to
determine
where it pastes the data.

I have code to enable it to copy and paste the data into the sheets - but
not the functionality to match the data to the correct sheets.

here is the main loop, just insert you copy/paste sheet code in the match
place

----
done = false
for each ws in master.sheets
if ws.name = wbdatafile.name then
'sheet match -> copy from wb data file to master sheet
done = true
exit for
end if
next
if not done then
msgbox "not matched, not pasted!"
end if
----

 

[BoRed79]

Thanks for your help - I think it has got me a step in the right direction -
however, it still does not appear to be working. Can anyone suggest a
modification to the code to make it work. The code as it stands at the
moment is as follows:

Dim strWSName As String
Dim ws As Worksheet

done = False

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

For Each ws In ActiveWorkbook.Worksheets

'match the left four characters of the filename and sheet name

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


Thanks for your anticipated help!

 

[sali]

Thanks for your help - I think it has got me a step in the right
direction -
however, it still does not appear to be working. Can anyone suggest a
modification to the code to make it work. The code as it stands at the

i can't see what is the your code layout, something like:

1] open master file
2] open *all* of the data files
3] start a loop processing one-by-one data file
4] target curent data file
5] do a data-file/master-sheet matching as described
6] if matched, do a copy/paste, otherwise alert of invalid data-file
7] target next data file, until loop 3] exhausted
8] close data-files, save master, eventualy generate report of success

if you agree on this model [or present your own], we may try to improve your
code to became functional

 

[BoRed79]

Hi.

The model that you have suggested appears to be a very sensible approach to
the problem - however - I am not really sure where to start in modifying my
code to make this happen.

Liz.

Thanks for your help - I think it has got me a step in the right
direction -
however, it still does not appear to be working. Can anyone suggest a
modification to the code to make it work. The code as it stands at the

i can't see what is the your code layout, something like:

1] open master file
2] open *all* of the data files
3] start a loop processing one-by-one data file
4] target curent data file
5] do a data-file/master-sheet matching as described
6] if matched, do a copy/paste, otherwise alert of invalid data-file
7] target next data file, until loop 3] exhausted
8] close data-files, save master, eventualy generate report of success

if you agree on this model [or present your own], we may try to improve your
code to became functional






.

 

[sali]

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

 

[BoRed79]

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").GetFolder(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