Moderatori: Anthony47, Flash30005
Sub SideBySide()
Dim TabSh As String, Tab1Adr As String, Tab2Adr As String, LastCol As Long
Dim TabC As Range, I As Long, pRow As Long, NextR As Long
'
Application.DisplayAlerts = False
On Error Resume Next
Sheets("ZcWork").Delete
Sheets("ZcPrint").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'
TabSh = "Elenco" '<<<-- Il foglio con la tabella di origine
'NB: il prossimo parametro deve cominciare da A1;
'es: corretto A1:F1
' sbagliati B1:F1, A2:G2
Tab1Adr = "A1:D1" '<<<-- La larghezza della prima tabella
'
Tab2Adr = Range(Tab1Adr).Offset(0, Range(Tab1Adr).Count + 1).Address
LastCol = Range(Tab2Adr).Offset(0, Range(Tab1Adr).Count - 1).Column
'
'Crea copia del foglio Elenco
Sheets(TabSh).Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "ZcWork"
Range(Tab1Adr).Resize(20, Range(Tab1Adr).Count).Copy Destination:=Range(Tab2Adr)
'Imposta larghezza colonne come originale
For Each TabC In Range(Tab1Adr)
Range(Tab2Adr).Offset(0, I).ColumnWidth = TabC.ColumnWidth
I = I + 1
Next TabC
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.View = xlNormalView
If ActiveSheet.VPageBreaks.Count > 0 Then 'Ridimensiona per 1 pagina
With ActiveSheet.PageSetup
.Orientation = xlPortrait
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
End With
End If
'Crea foglio di stampa
ActiveSheet.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "ZcPrint"
Range(Tab2Adr).Resize(25).ClearContents
'
Sheets("ZcWork").Select
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.View = xlNormalView
'
'Copia Work in Print
If ActiveSheet.HPageBreaks.Count > 0 Then
pRow = ActiveSheet.HPageBreaks(1).Location.Row - 3
Sheets("ZcPrint").Cells.Clear
Range(Tab1Adr).Copy Sheets("ZcPrint").Range("A1") 'Copia header
Range(Tab1Adr).Copy Sheets("ZcPrint").Range(Tab2Adr)
For I = 2 To Cells(Rows.Count, 1).End(xlUp).Row Step pRow * 2 'Copia dati
NextR = Sheets("ZcPrint").Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A" & I).Resize(pRow, Range(Tab1Adr).Count).Copy Destination:= _
Sheets("ZcPrint").Cells(NextR, "A")
Range("A1").Offset(I + pRow - 1, 0).Resize(pRow, Range(Tab1Adr).Count).Copy Destination:= _
Sheets("ZcPrint").Cells(NextR, Range(Tab2Adr).Column)
' set page break
Sheets("ZcPrint").HPageBreaks.Add before:=Sheets("ZcPrint").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next I
End If
Sheets("ZcPrint").Select
MsgBox ("Completato...")
End Sub
Come diceva Catullo, o Neruda, o forse solo Rossella (non ricordo piu' bene ), "domani e' un altro giorno, si vedrà"...Anthony ha scritto:il tuo caso scivola inesorabilmente a domani
Sub SideBySide2()
Dim TabSh As String, Tab1Adr As String, Tab2Adr As String, LastCol As Long
Dim TabC As Range, I As Long, pRow As Long, NextR As Long, Pag1 As Long '**
'
Application.DisplayAlerts = False
On Error Resume Next
Sheets("ZcWork").Delete
Sheets("ZcPrint").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'
TabSh = "Elenco" '<<<-- Il foglio con la tabella di origine
'NB: il prossimo parametro deve cominciare da A1;
'es: corretto A1:F1
' sbagliati B1:F1, A2:G2
Tab1Adr = "A1:D1" '<<<-- La larghezza della prima tabella
'
Tab2Adr = Range(Tab1Adr).Offset(0, Range(Tab1Adr).Count + 1).Address
LastCol = Range(Tab2Adr).Offset(0, Range(Tab1Adr).Count - 1).Column
'
'Crea copia del foglio Elenco
Sheets(TabSh).Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "ZcWork"
Range(Tab1Adr).Resize(20, Range(Tab1Adr).Count).Copy Destination:=Range(Tab2Adr)
'Imposta larghezza colonne come originale
For Each TabC In Range(Tab1Adr)
Range(Tab2Adr).Offset(0, I).ColumnWidth = TabC.ColumnWidth
I = I + 1
Next TabC
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.View = xlNormalView
If ActiveSheet.VPageBreaks.Count > 0 Then 'Ridimensiona per 1 pagina
With ActiveSheet.PageSetup
.Orientation = xlPortrait
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
End With
End If
'Crea foglio di stampa
ActiveSheet.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "ZcPrint"
Range(Tab2Adr).Resize(25).ClearContents
'
Sheets("ZcWork").Select
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.View = xlNormalView
'
'Copia Work in Print
If ActiveSheet.HPageBreaks.Count > 0 Then
pRow = ActiveSheet.HPageBreaks(1).Location.Row - 3
Sheets("ZcPrint").Cells.Clear
Range(Tab1Adr).Copy Sheets("ZcPrint").Range("A1").Offset(28, 0) '** 'Copia header
Range(Tab1Adr).Copy Sheets("ZcPrint").Range(Tab2Adr).Offset(28, 0) '**
Pag1 = 28 '**
For I = 2 To Cells(Rows.Count, 1).End(xlUp).Row Step pRow * 2 'Copia dati
NextR = Sheets("ZcPrint").Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A" & I).Resize(pRow - Pag1, Range(Tab1Adr).Count).Copy Destination:= _
Sheets("ZcPrint").Cells(NextR, "A") '**
Range("A1").Offset(I + pRow - 1 - Pag1, 0).Resize(pRow - Pag1, Range(Tab1Adr).Count).Copy Destination:= _
Sheets("ZcPrint").Cells(NextR, Range(Tab2Adr).Column) '**
' set page break
Sheets("ZcPrint").HPageBreaks.Add before:=Sheets("ZcPrint").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
If I = 2 Then I = I - Pag1 * 2: Pag1 = 0 '**
Next I
End If
Sheets("ZcPrint").Select
Range("A26").Value = "Descrizione:"
Range("A25").Value = "Revisione: " & Sheets("Revisioni").Range("A2") & " - del " _
& Format(Sheets("Revisioni").Range("B2"), "dd-mm-yyyy") & " - Realizzata da: " _
& Sheets("Revisioni").Range("C2")
Range("A1").Value = "TITOLO"
MsgBox ("Completato...")
End Sub
Range("A26").Value = "Descrizione:"
Torna a Applicazioni Office Windows
Macro che scatta quando cambia dato in un altro file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 12 |
Problema con macro copia e rinomina file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 2 |
Macro che ricerca combinazioni che danno un valore Autore: kar64 |
Forum: Applicazioni Office Windows Risposte: 10 |
Macro che indica la riga prima della cella attiva Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 19 |
Visitano il forum: systemcrack e 65 ospiti