Automatically make new excel-files (and save in specific folder on my computer)

Hi..

Attaching an image might help you if this was a photoshop forum..

Best to attach an excel file showing raw data and desired result.

Thanks for your advice.

I attached a file with raw data.

Maybe:

Sub Josvanderwaaij()
Dim wbkTest As Worksheet
Dim i As Long
Dim x As String
Dim wbk As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wbkTest = ActiveSheet
For i = 2 To Range("G" & Rows.count).End(3).Row
x = wbkTest.Range("G" & i).Value & " - " & wbkTest.Range("H" & i).Value & ".xls"
On Error Resume Next
Workbooks.Add
ActiveWorkbook.SaveAs x
Sheets("Sheet1").Rows(1).Value = wbkTest.Rows(1).Value
On Error GoTo 0
wbkTest.Activate
Next i
For Each wbk In Workbooks
    If Left(wbk.Name, 4) = "Book" Then wbk.Close
Next wbk
wbkTest.Activate
For i = 2 To Range("G" & Rows.count).End(3).Row
x = wbkTest.Range("G" & i).Value & " - " & wbkTest.Range("H" & i).Value & ".xls"
If Left(wbkTest.Range("G" & i).Value, 3) = Left(Workbooks(x).Name, 3) Then
    wbkTest.Rows(i).Copy Workbooks(x).Sheets("Sheet1").Range("A" & Rows.count).End(3)(2)
End If
wbkTest.Activate
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Thanks so far.

Couple of problems.

1. add new workbooks with names is working correctly
- only he makes also a lot of new maps without a name and didn't close those new maps.

2. He didn't name the sheet the same as the workbook and he didn't copy the values in the sheet.

Can you help me? I still have to learn a lot about VBA.

Try:

Sub Josvanderwaaij()
Dim wbkTest As Worksheet
Dim i As Long
Dim x As String
Dim wbk As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wbkTest = ActiveSheet
For i = 2 To Range("G" & Rows.count).End(3).Row
x = wbkTest.Range("G" & i).Value & " - " & wbkTest.Range("H" & i).Value & ".xlsx"
On Error Resume Next
Workbooks.Add
ActiveWorkbook.SaveAs x
Sheets("Sheet1").Rows(1).Value = wbkTest.Rows(1).Value
Sheets("Sheet1").Name = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5)
On Error GoTo 0
wbkTest.Activate
Next i
For Each wbk In Workbooks
    If Left(wbk.Name, 4) = "Book" Then wbk.Close
Next wbk
wbkTest.Activate
For i = 2 To Range("G" & Rows.count).End(3).Row
x = wbkTest.Range("G" & i).Value & " - " & wbkTest.Range("H" & i).Value & ".xlsx"
If Left(wbkTest.Range("G" & i).Value, 3) = Left(Workbooks(x).Name, 3) Then
    wbkTest.Rows(i).Copy Workbooks(x).Sheets(Left(Workbooks(x).Name, Len(Workbooks(x).Name) - 5)).Range("A" & Rows.count).End(3)(2)
End If
wbkTest.Activate
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Knipsel.JPG

Originally Posted by JOHN H. DAVIS

Maybe:

Sub Josvanderwaaij()
Dim wbkTest As Worksheet
Dim i As Long
Dim x As String
Dim wbk As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wbkTest = ActiveSheet
For i = 2 To Range("G" & Rows.count).End(3).Row
x = wbkTest.Range("G" & i).Value & " - " & wbkTest.Range("H" & i).Value & ".xls"
On Error Resume Next
Workbooks.Add
ActiveWorkbook.SaveAs x
Sheets("Sheet1").Rows(1).Value = wbkTest.Rows(1).Value
On Error GoTo 0
wbkTest.Activate
Next i
For Each wbk In Workbooks
    If Left(wbk.Name, 4) = "Book" Then wbk.Close
Next wbk
wbkTest.Activate
For i = 2 To Range("G" & Rows.count).End(3).Row
x = wbkTest.Range("G" & i).Value & " - " & wbkTest.Range("H" & i).Value & ".xls"
If Left(wbkTest.Range("G" & i).Value, 3) = Left(Workbooks(x).Name, 3) Then
    wbkTest.Rows(i).Copy Workbooks(x).Sheets("Sheet1").Range("A" & Rows.count).End(3)(2)
End If
wbkTest.Activate
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

I get also message with this error (see attachement)
Fould 9 - Subscript is out of range

Hi..

Only the data for the Unique value in Column G.

So.. as an example.. would that mean that the first file would be called '1206 - Praktijkhuisman.xlsx' and it should have a sheet called the same name and on that sheet would be the data from A2:L5?

And second file would be called '205 - De Hoeksteen.xlsx'. having a sheet in it called the same and data would be from A6:L6?

Yes, that is correct! It would save me a lot of time.

Based on the posts try this on the Dutch version. Although trial and error may not be the best way to decipher a different language.

Sub Josvanderwaaij()
Dim wbkTest As Worksheet
Dim i As Long
Dim x As String
Dim wbk As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wbkTest = ActiveSheet
For i = 2 To Range("G" & Rows.count).End(3).Row
x = wbkTest.Range("G" & i).Value & " - " & wbkTest.Range("H" & i).Value & ".xlsx"
On Error Resume Next
Workbooks.Add
ActiveWorkbook.SaveAs x
Sheets("Sheet1").Rows(1).Value = wbkTest.Rows(1).Value
Sheets("Sheet1").Name = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5)
On Error GoTo 0
wbkTest.Activate
Next i
For Each wbk In Workbooks
    If Left(wbk.Name, 3) = "Map" Then wbk.Close
Next wbk
wbkTest.Activate
For i = 2 To Range("G" & Rows.count).End(3).Row
x = wbkTest.Range("G" & i).Value & " - " & wbkTest.Range("H" & i).Value & ".xlsx"
If Left(wbkTest.Range("G" & i).Value, 3) = Left(Workbooks(x).Name, 3) Then
    wbkTest.Rows(i).Copy Workbooks(x).Sheets(Left(Workbooks(x).Name, Len(Workbooks(x).Name) - 5)).Range("A" & Rows.count).End(3)(2)
End If
wbkTest.Activate
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub