Altro problema collaterale, la macro di cui sopra genera altri n fogli, da qui la necessità di identificare la famosa TABELLA_20 (1)e trasferirla pari pari su "Foglio1" (2), aggiungendole in sequenza (3)
Ora sino al punto 2, ci sono arrivato ma ... la sequenza non ci va!!!
Non riesco a creare il loop che mi faccia la scansione di tutti i fogli, a partire dal numero +basso, (escluso Foglio1 ed Elabora ) copiando la tavella 20 a aggiungendola l'una sotto l'altra. Allego quanto fatto .
La prima macro funziona ma non "sequenzia" un accidente , la seconda è un tentativo che non sono riuscito a integrare.
- Codice: Seleziona tutto
Option Explicit
Sub Cerca_copia()
'
On Error GoTo 10
Dim ur As Long, uc As Long, UR1 As Long, UC1 As Long
Dim I As Long
Dim TextToFind As String
Dim Msg As String
Dim Response As Integer, Record As Integer
Dim Riga As Long, col As Long, x As Long, y As Long
Dim ws1, ws2 As Worksheet
TextToFind = "TABELLA_20"
Set ws1 = ActiveSheet
Set ws2 = Worksheets("Foglio1")
ws1.Activate
Columns("A:A").Select
Selection.Interior.ColorIndex = xlNone
Record = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
For I = 1 To Record
Selection.Find(What:=TextToFind, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
ActiveCell.Select ' trovata la cella la colora in giallo
With Selection.Interior
.ColorIndex = 36
End With
'fino a qui sembra andare bene
Riga = 99 ' <<<<<< prima criticità : non è possibile sulla base della cella activa gia trovata sopra identificare il range senza fissarlo
'(una sorta di range variabile dato che questo riferimento puo varaiare di volta in volta ???
ur = Cells(Riga, 1).End(xlDown).Row 'per foglio activo
col = 1
uc = Cells(Riga, col).End(xlToRight).Column
Range(Cells(Riga, col), Cells(ur, uc).End(xlToRight)).Select
'UR1 = ws2.Range("A1" & Rows.Count).End(xlUp).Row ' trova ultima riga piena di fo 1
'UC1 = ws2.Range("A1" & Columns.Count).End(xlLeft).Column ' trova ultima colonna piena di fo 1
'Selection.Copy Destination:=ws2.Range(Cells(UR1, 1)) ' copia immediatamente sotto l'ultima riga
'<<<< questa non funziona ???? se rimossa e attivata la riga sotto tutto funziona ma non accoda.
' ws2.Range("A" & UR1).PasteSpecial xlValues
Selection.Copy Destination:=ws2.Range("A1")
Next I
10:
End
Application.ScreenUpdating = True
ws2.Activate
Range("a1").Select
End Sub
Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For ws = 1 To WS_Count
If ws.Name <> "Foglio1" And ws.Name <> "Elabora" Then
' qui dovrei inserire la copia-incolla -ma come integrare il tutto con la macro sopra ?
End If
Next ws
MsgBox ActiveWorkbook.Worksheets(I).Name
End Sub
e qui il file
http://www.filedropper.com/3scaricawebm ... anthony03c