PDA

View Full Version : VBA search for files stored in mac time capsule



thebute
02-18-2014, 08:09 AM
Hi All,

this is my first post.
I have recently recieved some help on putting together a macro that searches for files (with "worksheet" in its name) in two speciphicly specified directories. The macro works great on a windows platform.
The challenge Im facing now is to have the maco do the same on our Mac machine.
additionaly Im also looking for help on having te macro search in subfolders specified in the two directoris.

The two directores that the macro should search through are as follow:
1: /Volumes/Time Capsule van Bute/ButeBV/dossiers 2014/Dossiers VP2: /Volumes/Time Capsule van Bute/ButeBV/dossiers 2014/Afgeronde dossiers/afgeronde dossiers VP

this is the macro mentioned: its stored in module MasterFile:

thanks for your help in advance
thebute


Dim vFiles As Variant


Sub DossierNummer()
Dim RimorMacro As String
Dim mysht As String

Application.ScreenUpdating = False

RimorMacro = ActiveWorkbook.Name
Sheets("OverzichtInhoud").Select
Range("A2:Q2" & ActiveSheet.UsedRange.Rows.Count).ClearContents
Range("A2").Select


Sheets("StartPunt").Select


get_filename
Sheets("StartPunt").Select
lrow = Range("E1", Selection.End(xlDown)).Count

For i = 2 To lrow
If Range("E" & i).Value = "" Then
MsgBox "Gegevens staan nu klaar in de OverzichtInhoud!", vbInformation, "Status Kopiëren"
Exit Sub
Else
Workbooks.Open Filename:=vFiles(1, i) & vFiles(2, i)

mysht = ActiveWorkbook.Name
Application.StatusBar = "De Tool is bezig met het verwerken van: " & mysht

Sheets("Worksheet").Select
Range("B4:B10,B29,B20,B24,B30,B31,B32,B33,B34,B35,B36").Select
Selection.Copy

Workbooks(RimorMacro).Activate
Sheets("OverzichtInhoud").Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

ActiveCell.Offset(0, 0).Select
Workbooks("" & mysht & "").Activate
Range("B24").Select

ActiveCell.Offset(0, 0).Select
Workbooks("" & mysht & "").Activate
Range("B24").Select

Selection.End(xlDown).Select
Selection.Copy
Workbooks("" & RimorMacro & "").Activate
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
Application.CutCopyMode = False
Sheets("StartPunt").Select

Workbooks(mysht).Close SaveChanges:=False
Workbooks(RimorMacro).Activate
End If
Next i
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub


Sub get_filename()
Const sPathRange As String = "C3,C7"
Const iIncr As Long = 50

Dim fdr As String

' this range will store your paths
Dim rngPathList As Excel.Range
Dim rng As Excel.Range

Dim iSize As Long

iSize = iIncr

mrow = 2

ReDim vFiles(1 To 2, 2 To iSize)

Set rngPathList = Range(sPathRange)

Range(Range("E2"), Range("E2").End(xlDown)).ClearContents
Range("E2").Select

For Each rng In rngPathList
spath = rng.Value
fdr = Dir(spath & "\*Worksheet*.xlsm")

Do While fdr <> ""
If mrow > iSize Then
iSize = iSize + iIncr
ReDim Preserve vFiles(1 To 2, 2 To iSize)
End If

vFiles(1, mrow) = spath & Application.PathSeparator
vFiles(2, mrow) = fdr

Cells(mrow, 5).Value = fdr

fdr = Dir
mrow = mrow + 1
Loop

If iSize >= mrow Then
iSize = mrow - 1
ReDim Preserve vFiles(1 To 2, 2 To iSize)
End If
Next rng
End Sub




11300