Template skal generere linjer i nyt ark

Så skal der noget VBA-kode til.
Du er velkommen til at sende filen. @-adresse under min profil.

Altid en ven i nøden - har sendt mail... :)

Er modtaget - vender tilbage..

Rem Version 1
Rem =========
Const sti = "C:\Users\peter\Desktop\Eksp.IrisFenchel"      '<--- TILPASSES (Skabelon & Fil forventes placeret her)

Dim xlsKontrakt As Workbook
Dim tabel(11)

Dim xlsSP As Workbook
Dim antalRæk As Integer, ræk As Integer, x As Integer
Const xlsSPfilNavn = "Sponsorliste.xlsx"
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If InStr(LCase(ActiveWorkbook.Name), ".xltm") > 0 Then
        Exit Sub
    End If
   
    Set xlsKontrakt = ActiveWorkbook

    Workbooks.Open (sti & "\" & xlsSPfilNavn)
    Set xlsSP = ActiveWorkbook
    xlsSP.Sheets(1).Activate
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
    ræk = antalRæk + 1
   
    xlsKontrakt.Activate
   
    tabel(0) = Range("C105") + Range("C111")        'beløb
    tabel(1) = Range("C31")                        'navn
    tabel(2) = Range("C32")                        'adresse
    tabel(3) = Range("C36")                        'CVR/SE
    tabel(4) = Range("C33")                        'kontakt
    tabel(5) = Range("C34")                        'tlf
    tabel(6) = Range("C35")                        'email
    tabel(7) = ""                                  'logo-sti
    tabel(8) = Range("D42")                        'fra dato
    tabel(9) = Range("D43")                        'til dato
    tabel(10) = Range("D47")                        'genforh.dato
   
    xlsSP.Activate
   
    With ActiveWorkbook
        For x = 0 To 10
            Range("A" & ræk).Offset(0, x) = tabel(x)
        Next x
    End With
   
Rem Luk sponsorliste
    xlsSP.Save
    xlsSP.Close
   
    Set xlsSP = Nothing
End Sub

Rem Version 2
Rem =========
Const sti = "C:\Users\Iris\Dropbox\Sponsor\Sponsor mappe"      '<--- TILPASSES (Skabelon & Fil forventes placeret her)

Dim xlsKontrakt As Workbook
Dim tabel(11)

Dim xlsSP As Workbook
Dim antalRæk As Integer, ræk As Integer, x As Integer, valg As String, svar, vNr As Integer
Const xlsSPfilNavn = "Sponsorliste.xlsx"
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

End Sub

    If InStr(LCase(ActiveWorkbook.Name), ".xltm") > 0 Then
        Exit Sub
    End If
   
    Set xlsKontrakt = ActiveWorkbook

    Workbooks.Open (sti & "\" & xlsSPfilNavn)
    Set xlsSP = ActiveWorkbook
    xlsSP.Sheets(1).Activate
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
   
    valg = "Tast nr" & vbCr & "0 Ny sponsor"
   
    For ix = 3 To antalRæk
        valg = valg & vbCr & ix & " " & Range("B" & ix) & " " & Range("C" & ix)
    Next ix
   
    svar = InputBox(valg, "Nyoprettelse eller opdatering")
   
    If svar = "" Then                              'cancel
        Exit Sub
    Else
        If IsNumeric(svar) = True Then
            vNr = svar
        Else
            Exit Sub                                'ej numerisk
        End If
    End If
   
    If vNr = 0 Then
        ræk = antalRæk + 1
    Else
        ræk = vNr
    End If
   
    xlsKontrakt.Activate
   
    tabel(0) = Range("C105") + Range("C111")        'beløb
    tabel(1) = Range("C31")                        'navn
    tabel(2) = Range("C32")                        'adresse
    tabel(3) = Range("C36")                        'CVR/SE
    tabel(4) = Range("C33")                        'kontakt
    tabel(5) = Range("C34")                        'tlf
    tabel(6) = Range("C35")                        'email
    tabel(7) = ""                                  'logo-sti
    tabel(8) = Range("D42")                        'fra dato
    tabel(9) = Range("D43")                        'til dato
    tabel(10) = Range("D47")                        'genforh.dato
   
    xlsSP.Activate
   
    With ActiveWorkbook
        For x = 0 To 10
            Range("A" & ræk).Offset(0, x) = tabel(x)
        Next x
    End With
   
Rem Luk sponsorliste
    xlsSP.Save
    xlsSP.Close
   
    Set xlsSP = Nothing
End Sub