Create a loop in VBA to copy data out of different files

[Hishaas]

I'm trying to help a collegue to write a code to copy data from several other files into one overview. All of our employees are writing there hours in an Excel file, which is saved on the server. I've managed to create a link to the path with the year and week numbers. These paths are variable.
I've also managed to write a code (see below) that opens the personal hours file of the person in row 2, copy the data to the right cells in row 2 and close the personal file again.
What I didn't manage yet is to create a loop which opens the file of the employee on row 3/4/5 etc. to copy the data in to there row.

FT3 = path;
AG2 and down = filenames;
AH2, AM2, AO2 and down are for the copied data;

The code:

Sub Doorvoeren()
Dim thisWorkbook As Workbook
Dim check_value As String
Dim I As Long
Dim RowCount As Long

'Get path from cell FT3 on Mulder Montage tab
fromPath = Sheets("Mulder Montage").Range("FT3")

'Make sure there is a backslash at the end of the from path
If Right(fromPath, 1) <> "" Then fromPath = fromPath & ""

Set thisWorkbook = ActiveWorkbook

If Right(folderPath, 1) <> "" Then folderPath = folderPath & ""

RowCount = Cells(Cells.Rows.Count, "T").End(xlDown).Rows.Count

For I = 1 To RowCount
Range("AG2").Select
fileName = Sheets("Mulder Montage").Range("ag2")

Set wkbFrom = Workbooks.Open(fromPath & fileName)

'Copy and paste data
Sheets("Werknemer").Select
Range("Z2:AD2").Select
Selection.Copy

Windows("Test.xlsm").Activate
Range("AH2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Windows(fileName).Activate
Range("AK2:AL2").Select
Application.CutCopyMode = False
Selection.Copy

Windows("Test.xlsm").Activate
Range("AM2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Windows(fileName).Activate
Range("BE2").Select
Selection.Copy

Windows("Test.xlsm").Activate
Range("AO2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Windows(fileName).Activate
ActiveWorkbook.Close savechanges:=False
Next I

MsgBox "Finished"
End Sub

[SamT]

First Step: I formatted the code in your post to make it legible to programmers
Second step: I removed all extras the Macro Recorder put in the code. This is almost the same code as in your post. I added some looping as I think you want.
You will still need to doublecheck it
Sub Doorvoeren()
Dim thisWorkbook As Workbook, TestBk As Workbook, ToSht as Worksheet '<--------------------
Dim fromPath As String
Dim I As Long
Dim RowCount As Long

'Get path from cell FT3 on Mulder Montage tab in this book
fromPath = Sheets("Mulder Montage").Range("FT3")
'Make sure there is a backslash at the end of the from path
If Right(fromPath, 1) <> "" Then fromPath = fromPath & "" 'Don't you mean "\" vice ""

RowCount = Cells(Cells.Rows.Count, "T").End(xlDown).Rows.Count

Set TestBk = Workbooks("Test.xlsm")
Set ToSht = TestBk.ActiveSheet

For I = 2 To RowCount '<-----------------
Set wkbFrom = Workbooks.Open(fromPath & Sheets("Mulder Montage").Cells(I, "ag"))

'Copy and paste data
With wkbFrom.Sheets("Werknemer")
.Range("Z2:AD2").Copy TestSht.Cells(Rows.Count, "AH").End(xlUp.Offset(1)
' Note that the two pastes below will be overwriting parts of the first paste
.Range("AK2:AL2").Copy TestSht.Cells(Rows.Count,"AM").End(xlUp)
.Range("BE2").CopyTestSht.Cells(Rows.Count,("AO").End(xlUp)
.Close savechanges:=False
End With
Next I

MsgBox "Finished"
End Sub

It would help us help you if we had some sample workbooks. (See Go Advanced button)

[snb]

Zijn het Excelbestanden of CSV-bestanden ?
Waarom een Engelstalig forum ?

[SamT]

Because we are the beste

[Hishaas]

Your are right I did a lot of things with the recording button, I am quite new in the VBA-business.
[QUOTE=SamT;409174]First Step: 'Don't you mean "" vice ""
This was correct, I think something went wrong during the copy-paste to the forum.

I get a syntaxerror on the formulas below
.Range("Z2:AD2").Copy TestSht.Cells(Rows.Count, "AH").End(xlUp.Offset(1)
.Range("AK2:AL2").Copy TestSht.Cells(Rows.Count,"AM").End(xlUp) <---- This one doesn't get an error:dunno
.Range("BE2").CopyTestSht.Cells(Rows.Count,("AO").End(xlUp)

The cells don't overwrite. I first copy 5 cells, then 2 and then 1. AH/AI/AJ/AK/AL = 5 ; AM/AN = 2 ; AO = 1, but thanks for checking.

In the attachments you'll find the test.xlsm and a few lists with hours (which also contain a code of which most of it is recorded, but this one was a lot easier and it works).

Thanks already for the effort you put in to my code. :bow:

[Hishaas]

Zijn het Excelbestanden of CSV-bestanden? (Are these Excel-files or CSV-files?) These are all Excel-files, see the attachments I've added to my reply to SamT

Waarom een Engelstalig forum ? (Why an English forum?) To get a larger public. And when I'm searching for answers I usually search the English forums, because you'll find more information, more answers and more problems...

[snb]

The best ? :whistle:


.Range("Z2:AD2").Copy TestSht.Cells(Rows.Count, "AH").End(xlUp.Offset(1)
.Range("AK2:AL2").Copy TestSht.Cells(Rows.Count,"AM").End(xlUp)
.Range("BE2").CopyTestSht.Cells(Rows.Count,("AO").End(xlUp)
Should be:


.Range("Z2:AD2").Copy TestSht.Cells(Rows.Count, 34).End(xlUp).Offset(1)
.Range("AK2:AL2").Copy TestSht.Cells(Rows.Count,39).End(xlUp)
.Range("BE2").Copy TestSht.Cells(Rows.Count,41).End(xlUp)

NB. Margriet, de website helpmij.nl kent veel meer deskundige helpers dan het handjevol (ca. 4) hier.

[Hishaas]

Unfortunately, the code doesn't open any of the files anymore.

[snb]

What is the meaning of 'the code' ?

On which grounds do you think so ?

[Hishaas]

The meaning is to copy the values of the cells into a overview with al our employees.

When I delete the part where the TestBk should be closed, none of the TestBk's stay open when the messagebox shows up in my screen.

[SamT]

@snb

Should be:


.Range("Z2:AD2").Copy TestSht.Cells(Rows.Count, 34).End(xlUp).Offset(1)
.Range("AK2:AL2").Copy TestSht.Cells(Rows.Count,39).End(xlUp)
.Range("BE2").Copy TestSht.Cells(Rows.Count,41).End(xlUp)

Hmmm... Why aren't the column letters working in that particular instance?

[snb]

Sometimes you forgot a bracket (line 1) , sometimes you added too many (line 3)