Døb Excel filen

Her er noget der kode der kan gøre det. Hvis du skal have passet det ind i den kode du har i forvejen, skal jeg lige se den (igen).

Dim fname As String

fname = [a6].Value & [d6].Value
ActiveWorkbook.SaveAs Filename:=fname, FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False

Hej bak.

Her er koden:

Sub OpretMapper()
Dim sti As String
Dim matrix As Variant
Dim StdWsh As Worksheet
Dim MedWsh As Worksheet
Dim SkaOpgwsh As Worksheet
Dim X As Integer, Y As Integer
Dim Oldsheets As Integer
Dim LastName As String
With ThisWorkbook
  Set StdWsh = .Sheets("skabelon")
  Set MedWsh = .Sheets("Medarbejdere")
  Set SkaOpgwsh = .Sheets("Opgørelse")
End With

With Application
  Oldsheets = .SheetsInNewWorkbook
  .SheetsInNewWorkbook = 1
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
End With

matrix = MedWsh.UsedRange
For X = 1 To UBound(matrix, 2)
  Workbooks.Add
  With ActiveWorkbook
    .Sheets(1).Name = matrix(1, X)
    SkaOpgwsh.Copy after:=Sheets(1)
    For Y = 3 To UBound(matrix, 1)
      If matrix(Y, X) = "" Then Exit For
      StdWsh.Copy after:=.Sheets(Y - 1)
      With ActiveSheet
        .Name = matrix(Y, X)
        .Range("D6") = matrix(Y, X)
        .Range("C4") = matrix(1, X)
        .Range("D5") = matrix(2, X)
        If Y >= 4 Then
            .Range("C8").Formula = "='" & matrix(3, X) & "'!C8"
            .Range("C8:c27").FillDown
        End If
        LastName = matrix(Y, X)  'arknavnet på sidste ark
      End With
    Next
    With Sheets("Opgørelse")
      .Range("b4") = matrix(1, X)  'indsætter Firmanavn
      .Range("B5") = matrix(2, X)  'Indsætter indkøbsordrenummer
      .Range("B8").Formula = "='" & matrix(3, X) & "'!C8" 'indsætter jobnummer
      '***** indsætter formel med timer
      .Range("C8").Formula = "=sum('" & matrix(3, X) & ":" & LastName & "'!D155)"
      '***** indsætter formel med overtid
      .Range("D8").Formula = "=sum('" & matrix(3, X) & ":" & LastName & "'!E155)"
      '***** Kopierer formlerne ned
      .Range("B8:D27").FillDown
      .Move after:=Sheets(LastName)  'Flytter opgørelsen til sidste Ark
    End With
  End With
  With Application
    .DisplayAlerts = False
    Sheets(1).Delete  '*** sletter 1. ark
    .DisplayAlerts = True
  End With
Next
With Application
  .SheetsInNewWorkbook = Oldsheets
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
End With
End Sub

Ok her er ny kode.
Som jeg kan se det er firmanavnet da i C4 og ikke i D6, så det har jeg gået ud fra, ellers kan du selv ændre det.


Sub OpretMapper()
Dim sti As String
Dim matrix As Variant
Dim StdWsh As Worksheet
Dim MedWsh As Worksheet
Dim SkaOpgwsh As Worksheet
Dim X As Integer, Y As Integer
Dim Oldsheets As Integer
Dim LastName As String
Dim Fname As String
With ThisWorkbook
  Set StdWsh = .Sheets("skabelon")
  Set MedWsh = .Sheets("Medarbejdere")
  Set SkaOpgwsh = .Sheets("Opgørelse")
End With

With Application
  Oldsheets = .SheetsInNewWorkbook
  .SheetsInNewWorkbook = 1
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
End With

matrix = MedWsh.UsedRange
For X = 1 To UBound(matrix, 2)
  Workbooks.Add
  With ActiveWorkbook
    .Sheets(1).Name = matrix(1, X)
    SkaOpgwsh.Copy after:=Sheets(1)
    For Y = 3 To UBound(matrix, 1)
      If matrix(Y, X) = "" Then Exit For
      StdWsh.Copy after:=.Sheets(Y - 1)
      With ActiveSheet
        .Name = matrix(Y, X)
        .Range("D6") = matrix(Y, X)
        .Range("C4") = matrix(1, X)
        .Range("D5") = matrix(2, X)
        If Y >= 4 Then
            .Range("C8").Formula = "='" & matrix(3, X) & "'!C8"
            .Range("C8:c27").FillDown
        End If
        LastName = matrix(Y, X)  'arknavnet på sidste ark
      End With
    Next
    With Sheets("Opgørelse")
      .Range("b4") = matrix(1, X)  'indsætter Firmanavn
      .Range("B5") = matrix(2, X)  'Indsætter indkøbsordrenummer
      .Range("B8").Formula = "='" & matrix(3, X) & "'!C8" 'indsætter jobnummer
      '***** indsætter formel med timer
      .Range("C8").Formula = "=sum('" & matrix(3, X) & ":" & LastName & "'!D155)"
      '***** indsætter formel med overtid
      .Range("D8").Formula = "=sum('" & matrix(3, X) & ":" & LastName & "'!E155)"
      '***** Kopierer formlerne ned
      .Range("B8:D27").FillDown
      .Move after:=Sheets(LastName)  'Flytter opgørelsen til sidste Ark
    End With
  End With
  With Application
    .DisplayAlerts = False
    Sheets(1).Delete  '*** sletter 1. ark
    .DisplayAlerts = True
  End With
  Fname = Sheets(1).Range("A6").Value & Sheets(1).Range("C4").Value
  ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False
Next
With Application
  .SheetsInNewWorkbook = Oldsheets
  .ScreenUpdating = True
  .Calculation = xlCalculationAutomatic
End With
End Sub

Det er C4, så du har ret, at jeg fik skrevet D6 skyldes måske vi kom lidt sent hjem fra vindmølle koncerten.  Eller virker det perfekt, Tak, du får lige 60 point.

Mfj1