Copiare tutti i fogli in uno solo (unire fogli di calcolo)

Question

Copiare tutti i fogli in uno solo (unire fogli di calcolo)

Anonimo

ho un file con numerosi fogli di calcolo.

Vorrei copiare tutti i fogli (solo la parte contenente dati) in uno unico.

E' possibile?

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

6 risposte

Answer 1

mi dice:

Error 13 (Tipo non corrispondente) alla riga230 nella routine: Tester

Ciao Filippo,

Potrei replicare il tuo errore se non dovessi dichiare la variabile Res come tipo Variant

Dim Res As Variant

Pertanto mi chiedo se tu abbia incollato il mio codice e, più in particolare, se il tuo codice includa una copia esatta delle righe suggerite:

'==========>>

Option Explicit

'---------->>

Public Sub Tester()

Dim WB As Workbook

Dim SH As Worksheet, destSH As Worksheet

Dim srcRng As Range, destRng As Range, headerRng As Range

Dim LRow As Long, LCol As Long

Dim arrEscludere As Variant

Dim Res As Variant

Dim i As Long

Dim CalcMode As Long

Dim blData As Boolean, blHeader As Boolean

Const sCartella As String = "Pippo.xlsx" '<<==== Modifica

Const sName As String = "Riepilogo" '<<==== Modifica

Tuttavia, dato che non hai la necessità di escludere qualsiasi dei fogli, prova a sostituire il codice precedente con la seguente versione semplificata:

'==========>>

Option Explicit

'---------->>

Public Sub Tester()

Dim WB As Workbook

Dim SH As Worksheet, destSH As Worksheet

Dim srcRng As Range, destRng As Range, headerRng As Range

Dim LRow As Long, LCol As Long

Dim arrEscludere As Variant

Dim CalcMode As Long

Dim blData As Boolean, blHeader As Boolean

Const sCartella As String = "Pippo.xlsx" '<<==== Modifica

Const sName As String = "Riepilogo" '<<==== Modifica

10 On Error GoTo ErrHandler

20 With Application

30 CalcMode = .Calculation

40 .Calculation = xlCalculationManual

50 .ScreenUpdating = False

60 End With

70 Set WB = Workbooks(sCartella)

80 With WB

90 If SheetExists(sName, WB) Then

100 Set destSH = .Sheets(sName)

110 destSH.UsedRange.EntireRow.Delete

120 Else

130 Set destSH = .Sheets.Add(Before:=.Sheets(1))

140 destSH.Name = sName

150 End If

160 For Each SH In .Worksheets

170 With SH

180 If Not .Name = sName Then

190 If headerRng Is Nothing Then

200 Set headerRng = .UsedRange.Rows(1)

210 End If

220 LRow = LastRow(SH, .UsedRange)

230 LCol = LastCol(SH, .UsedRange)

240 blData = LRow > 1

250 If blData Then

260 Set srcRng = Intersect(.UsedRange, .Rows(2)).Resize(LRow - 1, LCol)

270 If Not blHeader Then

280 With destSH

290 headerRng.Copy Destination:=.Range("A1")

300 Set destRng = .Range("A2")

310 End With

320 blHeader = True

330 End If

340 srcRng.Copy Destination:=destRng

350 Set destRng = destRng.Offset(LRow - 1)

360 End If

370 End If

380 End With

390 Next SH

400 End With

XIT:

410 On Error Resume Next

420 With Application

430 .Calculation = CalcMode

440 .ScreenUpdating = True

450 End With

460 On Error GoTo 0

470 Exit Sub

ErrHandler:

480 Call MsgBox(Prompt:="Error " _

& Err.Number _

& " (" _

& Err.Description _

& ") alla riga " & Erl _

& " nella routine: Tester", _

Buttons:=vbCritical, _

Title:="ERRORE")

490 Resume XIT

End Sub

'---------->>

Function LastRow(SH As Worksheet, _

Optional Rng As Range)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastRow = Rng.Find(What:="*", _

after:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

End Function

'---------->>

Function LastCol(SH As Worksheet, _

Optional Rng As Range)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastCol = Rng.Find(What:="*", _

after:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByColumns, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Column

On Error GoTo 0

End Function

'---------->>

Function SheetExists(aStr As String, Optional aWB As Workbook) As Boolean

If aWB Is Nothing Then

Set aWB = ActiveWorkbook

End If

On Error Resume Next

SheetExists = CBool(Len(aWB.Sheets(aStr).Name))

On Error GoTo 0

End Function

'<<==========

===

Regards,

Norman

Answer 2

Ciao Filippo,

ti chiederei alcune specifiche:

Const sCartella As String = "Pippo.xlsx" '<<==== Modifica

qui ci va il nome del file o della cartella?

Sì, questo è il nome del file.

Const sName As String = "Riepilogo" '<<==== Modifica

e qui? Il nome

Questo sarebbe il nome per il foglio in cui saranno copiati i dati degli altri fogli. Se questo foglio non esiste già, verrà creato e nominato dal codice.

Const sFogliDaEscludere As String = "Foglio5,Foglio12" '<<==== Modifica

Qui invece solo i fogli da escludere, vero? (non ne ho nel mio caso)

Se non ci sono dei fogli da escludere, sostituisci "Foglio5,Foglio12" con ""

===

Regards,

Norman

Answer 3

ho un file con numerosi fogli di calcolo.

Vorrei copiare tutti i fogli (solo la parte contenente dati) in uno unico.

E' possibile?

Ciao Filippo,

Prova come segue:

Alt-F11 per aprire l'editor di VBA

Alt-IM per inserire un nuovo modulo di codice

Nel nuovo modulo vuoto, incolla il seguente codice:

'==========>>

Option Explicit

'---------->>

Public Sub Tester()

Dim WB As Workbook

Dim SH As Worksheet, destSH As Worksheet

Dim srcRng As Range, destRng As Range, headerRng As Range

Dim LRow As Long, LCol As Long

Dim arrEscludere As Variant

Dim Res As Variant

Dim i As Long

Dim CalcMode As Long

Dim blData As Boolean, blHeader As Boolean

Const sCartella As String = "Pippo.xlsx" '<<==== Modifica

Const sName As String = "Riepilogo" '<<==== Modifica

Const sFogliDaEscludere As String = "Foglio5,Foglio12" '<<==== Modifica

10 On Error Resume Next

20 arrEscludere = Split(sFogliDaEscludere, ",")

30 For i = LBound(arrEscludere) To UBound(arrEscludere)

40 arrEscludere(i) = Trim(arrEscludere(i))

50 Next i

60 On Error GoTo ErrHandler

70 With Application

80 CalcMode = .Calculation

90 .Calculation = xlCalculationManual

100 .ScreenUpdating = False

110 End With

120 Set WB = Workbooks(sCartella)

130 With WB

140 If SheetExists(sName, WB) Then

150 Set destSH = .Sheets(sName)

160 destSH.UsedRange.EntireRow.Delete

170 Else

180 Set destSH = .Sheets.Add(Before:=.Sheets(1))

190 destSH.Name = sName

200 End If

210 For Each SH In .Worksheets

220 With SH

230 Res = Application.Match(.Name, arrEscludere, 0)

240 If Not .Name = sName And IsError(Res) Then

250 If headerRng Is Nothing Then

260 Set headerRng = .UsedRange.Rows(1)

270 End If

280 LRow = LastRow(SH, .UsedRange)

290 LCol = LastCol(SH, .UsedRange)

300 blData = LRow > 1

310 If blData Then

320 Set srcRng = Intersect(.UsedRange, .Rows(2)).Resize(LRow - 1, LCol)

330 If Not blHeader Then

340 With destSH

350 headerRng.Copy Destination:=.Range("A1")

360 Set destRng = .Range("A2")

370 End With

380 blHeader = True

390 End If

400 srcRng.Copy Destination:=destRng

410 Set destRng = destRng.Offset(LRow - 1)

420 End If

430 End If

440 End With

450 Next SH

460 End With

XIT:

470 On Error Resume Next

480 With Application

490 .Calculation = CalcMode

500 .ScreenUpdating = True

510 End With

520 On Error GoTo 0

530 Exit Sub

ErrHandler:

540 Call MsgBox(Prompt:="Error " _

& Err.Number _

& " (" _

& Err.Description _

& ") alla riga " & Erl _

& " nella routine: Tester", _

Buttons:=vbCritical, _

Title:="ERRORE")

550 Resume XIT

End Sub

'---------->>

Function LastRow(SH As Worksheet, _

Optional Rng As Range)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastRow = Rng.Find(What:="*", _

after:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByRows, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Row

On Error GoTo 0

End Function

'---------->>

Function LastCol(SH As Worksheet, _

Optional Rng As Range)

If Rng Is Nothing Then

Set Rng = SH.Cells

End If

On Error Resume Next

LastCol = Rng.Find(What:="*", _

after:=Rng.Cells(1), _

Lookat:=xlPart, _

LookIn:=xlFormulas, _

SearchOrder:=xlByColumns, _

SearchDirection:=xlPrevious, _

MatchCase:=False).Column

On Error GoTo 0

End Function

'---------->>

Function SheetExists(aStr As String, Optional aWB As Workbook) As Boolean

If aWB Is Nothing Then

Set aWB = ActiveWorkbook

End If

On Error Resume Next

SheetExists = CBool(Len(aWB.Sheets(aStr).Name))

On Error GoTo 0

End Function

'<<==========

Alt-Q per chiudere l'editor di VBA e tornare a Excel.

Alt-F8 per aprire la finestrina macro

Seleziona Tester | Esegui

===

Regards,

Norman

Answer 4

Ciao Norman,

ti chiederei alcune specifiche:

Const sCartella As String = "Pippo.xlsx" '<<==== Modifica

qui ci va il nome del file o della cartella?

Const sName As String = "Riepilogo" '<<==== Modifica

e qui?

Const sFogliDaEscludere As String = "Foglio5,Foglio12" '<<==== Modifica

Qui invece solo i fogli da escludere, vero? (non ne ho nel mio caso)

Answer 5

Anonimo

ho un file con numerosi fogli di calcolo.

Vorrei copiare tutti i fogli (solo la parte contenente dati) in uno unico.

E' possibile?

Sì, condivi però un file esemplificativo con le specifiche. Puoi utilizzare il servizio di condivisione che ti è più familiare.

0 commenti