Angiv Udskrift område med makro via Current.Region?

Indsæt dette i et modul

Sub Udskriv()

Dim Tom As Boolean, VL As Variant, T As Integer, R As Integer, I As Integer, AD As Integer
Application.ScreenUpdating = False
R = Range("E1").SpecialCells(xlLastCell).Row
AD = Range("E1").SpecialCells(xlLastCell).Column
For I = 1 To R
Tom = True
VL = Range(Cells(I, 1), Cells(I, AD)).Value
For T = 1 To AD
If VL(1, T) <> "" Then
Tom = False
Exit For
End If
Next

If Tom = True Then
Rows(I).EntireRow.Hidden = True
End If
Next
ActiveSheet.PrintOut
Cells.EntireRow.Hidden = False
Application.ScreenUpdating = True


End Sub

Med CurrentRegion vil det vist være noget i den her retning.

Worksheets("Journal Ark").Activate
ActiveSheet.PageSetup.PrintArea = ActiveCell.CurrentRegion.Address

Men jeg tror umiddelbart ikke at CurrentRegion kan begrænses til kun at teste på en kolonne, men jeg ved det ikke med sikkerhed.

Jeg prøver lige... vender tilbage

Fandt den her, http://www.eksperten.dk/spm/599478

der er også en variant der anvender den sædvanlige udskriv knap.

Range("E1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ActiveSheet.PageSetup.PrintArea = Selection.Address

rosco :
jeg har forsøgt med dit forslag, fik fejl i linie :
---- R = Range("E1").SpecialCells(xlLastCell).Row

jeg har ikke printer tilsluttet denne pc, kan det være problemet?

kabbak : dit forslag ser dejlig kort ud prøver lige den også

Ikke umuligt.
Jeg har selv brugt koden, med succes.

kabbak : jeg fik det ikke til at virke.
Hvis du har tid og lyst, kunne jeg sende filen til dig
jeg sætter mine sidste point på højkant hvis du er frisk på det
v.h.Poul

Det er forresten din kode Kabbak:
Var virkelig brugbar. :-)

hvilken version af excel bruger du ?

kabbak snabela tiscali punktum dk

2003

ok, marker lige det område du vil have som udskriftsområde, med en farve, inden du sender

Jeg går ud fra at der din "makro1", der skal arbejdes med.

Fordi det ikke lykkedes for dig, var at du havde sat scrollArea på, det skal fjernes for at hoden kan køre, så det fjernes først og sættes på igen.

Jeg har opdateret din kode også.

Sub Makro1()
'Journal
' Makro indspillet 13-01-2006 af POUL MADSEN
 
    info.Show
    DoEvents
    Application.ScreenUpdating = False
    Worksheets("Journal").Activate
    Worksheets("Journal").ScrollArea = ""
    Range("B4:J233").Select
    Selection.ClearContents
    For i = 1 To 10
    Worksheets("Side " & i).Range("B5:J27").Copy
   
    Worksheets("Journal").Range("C65536").End(xlUp).Offset(1, -1).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    Next
    Range("a1").Select
    Worksheets("Journal").Activate
    info.Hide
'----------------------------------------
Range("B3").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ActiveSheet.PageSetup.PrintArea = Selection.Address
    Worksheets("Journal").ScrollArea = "$A$1:$A$235"
    Application.ScreenUpdating = True
    ActiveWindow.SelectedSheets.PrintPreview
    Worksheets("Forside").Activate
    Range("m7").Select

End Sub

denne linie gør, at den finder det sidste bilagsnummer i rækken og placerer sig en til venstre og 1 nedenunder, så skulle der ikke være tomme imellem.

Worksheets("Journal").Range("C65536").End(xlUp).Offset(1, -1).Select

nææ, der skal lige kikkes lidt

så skulle det virke, jeg havde ikke set at du havde sum nederst.

Sub Makro1()
'Journal
' Makro indspillet 13-01-2006 af POUL MADSEN
    Dim RW As Long
    info.Show
    DoEvents
    Application.ScreenUpdating = False
    Worksheets("Journal").Activate
    Worksheets("Journal").ScrollArea = ""
    Range("B4:J233").ClearContents
    Range("B4:J233").Font.Bold = False
    For i = 1 To 10
        Worksheets("Side " & i).Range("B5:J27").Copy
        Worksheets("Journal").Range("C65536").End(xlUp).Offset(1, -1).Select
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Next
    Range("a1").Select
    Worksheets("Journal").Activate
    info.Hide
    '----------------------------------------
    RW = Range("C65536").End(xlUp).Offset(1, 3).Row
    ' Sætter sum under
    Range("C65536").End(xlUp).Offset(1, 3).FormulaR1C1 = "=SUM(R[-" & RW - 3 & "]C:R[-1]C)"
    Range("C65536").End(xlUp).Offset(1, 4).FormulaR1C1 = "=SUM(R[-" & RW - 3 & "]C:R[-1]C)"
    Range("C65536").End(xlUp).Offset(1, 6).FormulaR1C1 = "=SUM(R[-" & RW - 3 & "]C:R[-1]C)"
    Range("C65536").End(xlUp).Offset(1, 7).FormulaR1C1 = "=SUM(R[-" & RW - 3 & "]C:R[-1]C)"
    Range(Cells(RW + 1, 2), Cells(RW + 1, 7)).Font.Bold = True
    ActiveSheet.PageSetup.PrintArea = "B3:J" & RW

    Worksheets("Journal").ScrollArea = "$A$1:$A$235"
    Application.ScreenUpdating = True
    ActiveWindow.SelectedSheets.PrintPreview
    Worksheets("Forside").Activate
    Range("m7").Select

End Sub

ret lige

Range(Cells(RW + 1, 2), Cells(RW + 1, 7)).Font.Bold = True

til

Range(Cells(RW, 6), Cells(RW, 10)).Font.Bold = True

ok jeg prøver kabbak

perfekt kabbak mange tak for hjælpen v.h.Poul
jeg opretter lige et spørgsmål til de andre point
husk også det andet spørgsmål "tomme linier i datavalider"

ok et svar, der er point nok her ;-))