Bossie
New Member
I have a sourcefile (xlsm) with 18000 rows of data.
I need to copy two cells from each line to different sheets on different files (one per person).
So I browsed the internet and found a module that does the trick:
· It asks in which folder the target files are
· In a loop
o it opens file by file
o in a loop it opens sheet by sheet
o it finds the rows in the sourcefile with the data to copy
o it copies the data to the sheet
o it closes and saves the file
This works fine fora bout 10 files and then it shows an error ‘insufficient memory’
I need to make this work for about 1000 files so this is a problem.
Any thoughts on how to avoid this message?
this is the code (messy, I know)
I need to copy two cells from each line to different sheets on different files (one per person).
So I browsed the internet and found a module that does the trick:
· It asks in which folder the target files are
· In a loop
o it opens file by file
o in a loop it opens sheet by sheet
o it finds the rows in the sourcefile with the data to copy
o it copies the data to the sheet
o it closes and saves the file
This works fine fora bout 10 files and then it shows an error ‘insufficient memory’
I need to make this work for about 1000 files so this is a problem.
Any thoughts on how to avoid this message?
this is the code (messy, I know)
Code:
Sub teamscanteam()
'initialisaties
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Current As Worksheet
Dim persnr As String
Dim bronbestand As Workbook
Dim bronsht As Worksheet
Dim productpersnr As String
Dim gevonden
Dim gevondenlyn
'Optimimaliseren snelheid uitvoering macro
' Application.ScreenUpdating = False
' Application.EnableEvents = False
' Application.Calculation = xlCalculationManual
bronpad = "\\antwerpen.local\Doc\PM\1_16_Monitoren\05_Terugkerende_rapportering\22_teamscan\"
Set bronbestand = Workbooks("teamscan3_zonderformules3.xlsm")
Set bronsht = bronbestand.Worksheets("koppelingenSB")
'bepaal het pad waar de bestanden staan
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'extensie van de bestanden bepalen
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop door alle excelbestanden in de directory
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
' Loop door alle sheets in het geopende workbook
For Each Current In Worksheets
' Haal het personeelsnummer op
persnr = CStr(Current.Range("B3").Value)
'testers
Debug.Print Current.Name
Debug.Print persnr
For productlyn = 1 To 18107
productpersnr = bronsht.Cells(productlyn, 1).Value
If productpersnr = persnr Then gevondenlyn = productlyn
Next productlyn
Next
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
' Application.EnableEvents = True
' Application.Calculation = xlCalculationAutomatic
' Application.ScreenUpdating = True
End Sub
)