Új hozzászólás Aktív témák

• #42791 Delila_1 veterán daddy9 #42788

  Új Válasz 2020-01-22 14:05:07 #42791

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz daddy9 #42788 üzenetére

  Közben megadtad a választ arra, hogy ki mikor milyen oklevelet kap. Itt a módosított makró:

  Sub Pdf()
Dim sor As Integer, oszlop As Integer, utvonal As String, FN As String

Application.ScreenUpdating = False
oszlop = 3
Do While Cells(4, oszlop) <> ""
utvonal = Cells(24, oszlop)

If Cells(7, oszlop) = "fiú" Then sor = 25 Else sor = 26
FN = Cells(sor, oszlop)


Sheets(Cells(sor, 1)).Select 'lapra állás
With Sheets("Adatbekérő")
Range("A7") = .Cells(6, oszlop) & ", " & .Cells(5, oszlop)
Range("A13") = .Cells(8, oszlop)

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=utvonal & FN, _
Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=False

If .Cells(9, oszlop) = "Ügyes" Then
Sheets(.Cells(sor + 1, 1)).Select 'lapra állás
If .Cells(7, oszlop) = "fiú" Then sor = sor + 2 Else sor = sor + 1
FN = .Cells(sor, oszlop)
Range("A7") = .Cells(6, oszlop) & ", " & .Cells(5, oszlop)
Range("A13") = .Cells(8, oszlop)

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=utvonal & FN, _
Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
End With

Sheets("Adatbekérő").Select
oszlop = oszlop + 1
Loop

Application.ScreenUpdating = True
MsgBox "Az oklevelek el vannak mentve", vbInformation
End Sub

Új hozzászólás Aktív témák