Macro copia dati da/a colonne 2 fogli

[Ricky0185]

Buonasera, tempo fa Anthony mi risolse il problema di copiare da foglio un dato su altro foglio ma con lo stesso nome.Riusando la macro per lo stesso motivo si inchioda col classico errore di runtime 1004. Il file è moolto più grande di quello allegato, ma non capisco perchè la macro non funziona più.
Ringrazio e saluto
R

[Anthony47]

Quale e' la macro da esaminare e che cosa dovrebbe fare?

[Ricky0185]

Modulo2. Dovrebbe ragruppare/ricopiare su Foglio2 per ogni voce di ColonnaA tutte le corrispondenti voci di Colonnab del Foglio1.

[Ricky0185]

Elimina pure il Modulo1 e tieni solo il Modulo2.
Per esempio questa macro funziona e recupera su Foglio2 tutte le ricorrenze di "Bcc Roma" che si trovano su Foglio1 ColonnaB

Codice: Seleziona tutto

Sub CopiaBccRoma()
Dim CL As Range, iRow As Integer
Dim cArr(), cInd As Long, I As Long
ReDim cArr(1 To 4, 1 To 1)
'
Sheets("Foglio1").Select
Dim Area As Range
Set Area = Sheets("Foglio1").Range("b1:b10")
For Each CL In Area 'Range("b364:b1574")
    If CL.Value = "Bcc Roma" Then
        'Copia la riga in cArr:
        cInd = UBound(cArr, 2)
        For I = 1 To 4
            cArr(I, cInd) = CL.Offset(0, -2 + I).Value
        Next I
        ReDim Preserve cArr(1 To 4, 1 To cInd + 1)
    End If
Next CL
iRow = 14
While Worksheets("Foglio2").Cells(iRow, 2).Value <> ""
    iRow = iRow + 1
Wend
'Inserisce le righe in Foglio2:
Worksheets("Foglio2").Rows(iRow).Resize(cInd).Insert Shift:=xlDown 'errore 1004-Errore definito etc.etc
'Scrive il contenuto di cArr:
Worksheets("Foglio2").Cells(iRow, 2).Resize(UBound(cArr, 2), UBound(cArr)).Value = _
   Application.WorksheetFunction.Transpose(cArr)
Sheets("Foglio2").Select
   Set zona = Range([E14], [E14].End(xlDown))
[F13] = WorksheetFunction.Sum(zona)
End Sub

ed è esattamente uguale a quella che va in tilt

[Anthony47]

In colonna B hai

Codice: Seleziona tutto

Manut.Spazi Comuni
Ordinaria


(su due righe)

Lo confronti con

Codice: Seleziona tutto

Manut. Spazi Comuni Ordinaria

e quindi non ne trovi nessuno, sia perche' CL e' su due righe (in mezzo c'e' il carattere vbCrLf o chr(10) e sia perche' in CL manca qualche Spazio.

Successivamente cerchi di inserire le righe che servono, cioe' Zero; che ti generera' l'errore
Per evitare l'errore devi mettere sotto If la parte che aggiunge righe e le popola; tipo

Codice: Seleziona tutto

If cInd >1 then
' le istruzioni
End If


Ma poi devi fare in modo di avere in CL stringhe confrontabili; ad esempio

Codice: Seleziona tutto

    If Replace(Replace(CL.Value, Chr(10), " ", , , vbTextCompare), " ", "", , , vbTextCompare) = "Manut.SpaziComuniOrdinaria" Then

toglie i vbCrLf e gli Spazi da CL in modo che puoi confrontarlo con qualcosa di prevedibile

Ciao

[Ricky0185]

In giornata devo capire e provare. Grazie comunque.
R

[Ricky0185]

Buongiorno, torno sull’argomento poichè ho bisogno di aiuto.
Nel fileallegato la macro svolge egregiamente il suo lavoro, ma poiché gli articoli da trattare (ripetendo per ciascuno la stessa macro) sono molti e con nomi diversi, vorrei nella macro automatizzare il numero “14” nella riga “irow=14”.
Questo ovviamente poiché per esempio quando sarà

Codice: Seleziona tutto

If CL.Value = "Cancelleria" Then

la riga 14 dovrà essere sicuramente di più considerando tutte le righe aggiunte sul Foglio2 ricopiate da Foglio1.
Va da sé che anche le celle di cui

Codice: Seleziona tutto

Sheets("Foglio2").Select
   Set zona = Range([E14], [E14].End(xlDown))
[F13] = WorksheetFunction.Sum(zona)

dovrebbero seguire lo stesso ragionamento.
Penso magari facendo riferimento alla voce di cui trasferire le righe su Foglio2.
Grazie
Saluti
R

[Ricky0185]

Avrei anche risolto con uno stratagemma. Sulla base della macro suggerita da Anthony l'ho modificata

Codice: Seleziona tutto

Sub CopiaBccRoma()
Dim cl As Range, iRow As Integer
Dim cArr(), cInd As Long, I As Long
ReDim cArr(1 To 4, 1 To 1)
'
Sheets("Foglio1").Select
Dim Area As Range
Set Area = Sheets("Foglio1").Range("b1:b10")
For Each cl In Area 'Range("b364:b1574")
    If cl.Value = "Bcc Roma" Then
        'Copia la riga in cArr:
        cInd = UBound(cArr, 2)
        For I = 1 To 4
            cArr(I, cInd) = cl.Offset(0, -2 + I).Value
        Next I
        ReDim Preserve cArr(1 To 4, 1 To cInd + 1)
    End If
Next cl

Sheets("Foglio2").Select
For Each cl In Sheets("Foglio2").Range("a8:a47")
If cl.Value = "Bcc Roma" Then
cl.Select
End If
Next
Range("H13") = ActiveCell.Row

iRow = ActiveCell.Row '14
While Worksheets("Foglio2").Cells(iRow, 2).Value <> ""
    iRow = iRow + 1
Wend
'Inserisce le righe in Foglio2:
Worksheets("Foglio2").Rows(iRow).Resize(cInd).Insert Shift:=xlDown
'Scrive il contenuto di cArr:
Worksheets("Foglio2").Cells(iRow, 2).Resize(UBound(cArr, 2), UBound(cArr)).Value = _
   Application.WorksheetFunction.Transpose(cArr)
Sheets("Foglio2").Select
   Set zona = Range(ActiveCell.Offset(0, 4), ActiveCell.Offset(0, 4).End(xlDown))
ActiveCell.Offset(0, 5) = WorksheetFunction.Sum(zona)
End Sub

però non capisco perche mi trascrive su Foglio2 i valori della ricerca iniziando da tre righe in alto invece che da una riga in basso.
Ho provato a cambiare l'articolo della ricerca, ma stesso risultato.
Sicuramente non ho capito bene la macro di Anthony

[Anthony47]

E' stato piu' lungo capire che cosa stavi chiedendo (e non sono certo di averlo capito) che abbozzare una soluzione...

Ho immaginato che tu voglia creare il Rendiconto su Foglio2, riepilogando le voci presenti sull'analitico di Foglio1.
Per questo, prendendo spunto dalla Sub CopiaBccRoma, creiamoci una Sub CopiaMod, modulare, che poi richiamiamo per ogni voce presente in colonna A del Rendiconto.
E' comunque necessario che le voci su Rendiconto siano riportate nello stesso modo che in Analitico (Foglio1)

Il codice complessivo:

Codice: Seleziona tutto

Sub CopiaMod(ByVal CheCosa As String, iiRow As Long)
Dim CL As Range, iRow As Integer, lSum As Single
Dim cArr(), cInd As Long, I As Long
ReDim cArr(1 To 4, 1 To 1)
'
''Sheets("Foglio1").Select
Dim Area As Range
Set Area = Range(Sheets("Foglio1").Range("b1"), Sheets("Foglio1").Range("b1").End(xlDown))
Debug.Print "Cerca " & CheCosa & " in Foglio1!" & Area.Address(0, 0)
For Each CL In Area
    If UCase(CL.Value) = UCase(CheCosa) And CL.Interior.Color <> RGB(100, 255, 100) Then
        'Copia la riga in cArr:
        cInd = UBound(cArr, 2)
        CL.Interior.Color = RGB(100, 255, 100)
        For I = 1 To 4
            cArr(I, cInd) = CL.Offset(0, -2 + I).Value
        Next I
        lSum = lSum + cArr(4, cInd)
        ReDim Preserve cArr(1 To 4, 1 To cInd + 1)
    End If
Next CL
If cInd > 0 Then
    Debug.Print "Inserisco " & cInd & " righe sul riepilogo della voce " & CheCosa & ", SubTot: "; Format(lSum, "0.00")
    iRow = iiRow
    While Worksheets("Foglio2").Cells(iRow, 2).Value <> ""
        iRow = iRow + 1
    Wend
    'Inserisce le righe in Foglio2:
    Worksheets("Foglio2").Rows(iRow).Resize(cInd).Insert Shift:=xlDown
    'Scrive il contenuto di cArr:
    Worksheets("Foglio2").Cells(iRow, 2).Resize(UBound(cArr, 2), UBound(cArr)).Value = _
       Application.WorksheetFunction.Transpose(cArr)
    Sheets("Foglio2").Cells(iRow + cInd - 1, "F").Value = lSum
End If
End Sub


Sub MakeRendiconto()
Dim myVoci As Range, myC As Range, I As Long

Sheets("Foglio2").Select
Set myVoci = Range(Range("A8"), Cells(Rows.Count, 1).End(xlUp))
Debug.Print vbCrLf, ">>>> Start", myVoci.Address(0, 0)
For Each myC In myVoci
    If Len(myC.Value) > 1 Then
        Call CopiaMod(myC.Value, myC.Row + 1)
    End If
Next myC
End Sub


La sub da avviare e' MakeRendiconto

Provala su una copia del tuo file.

Su Foglio1 le voci che vengono riportate su Foglio2 verranno colorate di Verdino. Quindi a conclusione della MakeRendiconto se ispezioni Foglio1 vedrai che alcune righe sono rimaste bianche: ispeziona la terminologia usata su Foglio1 e confrontala con quella di Foglio2, e risolvi le differenze.
A questo punto puoi ripetere la MakeRiepilogo, che ignorera' le righe gia' in verde ed esaminera' solo le restanti.

Hai un problema con le formule inserite in colonna G-Totale, ad esempio il Totale di SPESE GENERALI non includera' le spese classificate come Varie. Riscrivile facendo in modo che includano dalla prima riga della categoria fino alla stessa riga che contiene il totale

Buone prove...

[Ricky0185]

Che dire: eccezionale è riduttivo.
Siccome, per tenere sotto controllo le uscite, devo lanciare la macro diverse volte nel tempo e quindi ti chiederei come cancellare all'apertura i valori precedentemente inseriti, poichè altrimenti vengono aggiunti in coda a quelli esistenti generando doppioni.
Per il colore non c'è problema

Codice: Seleziona tutto

......Interior.ColorIndex = xlNone

ma per cancellare le registrazioni già riportate non so come fare.
Ti ringrazio comunque per quanto fatto, hai centrato in pieno la soluzione alla mia richiesta, ancorchè poco chiara.
Cordiali saluti
R

[Anthony47]

Se lasci il colore allora le celle colorate non verranno prese in considerazione e non dovrebbero esserci doppioni
Per un colore meno invadente basta modificare RGB(X, Y, Z) es RGB(200, 255, 200) corrisponde a un verdino pallido pallido

[Ricky0185]

Questo vale per i colori sul Foglio1, ma sul Foglio2 vengono ririportati gli stessi valori inseriti con la MakeRendiconto precedente generando doppioni. Almeno a me da questo risultato.

[Anthony47]

Questo vale per i colori sul Foglio1, ma sul Foglio2 vengono ririportati gli stessi valori inseriti con la MakeRendiconto precedente generando doppioni. Almeno a me da questo risultato.

Hummm...
Mi sovviene che usi una versione "vecchiotta" di Excel, potrebbe avere una gestione limitata di Color...

Invece di usare .Color <> RGB(100, 255, 100) e .Color = RGB(100, 255, 100) usa rispettivamante

Codice: Seleziona tutto

.ColorIndex <> 19


e

Codice: Seleziona tutto

.ColorIndex = 19


Ho usato colorindex=19 che (sulla mia macchia) corrisponde a un giallino tenue; valuta tu che index preferisci tra i 56 disponibili.

Quanto a "resettare" la t abella Rendiconto, si puo' fare ma non lamentarti se poi ti cancella qualcosa che ti serve; meglio sarebbe creare un "modello" e volta per volta duplicare questo modello (tasto dx sul tab col Nome, scegli Sposta o copia, scegli la posizione e spunta "Crea una copia") e chiamarlo Foglio2.
Comunque una cosa che a me sembra funzionare e' questa:

Codice: Seleziona tutto

Sub Restora()
Dim I As Long, LastR As Long
Dim cLine As Long, bLen As Long, Dbg As Boolean
'
Sheets("Foglio2").Select
LastR = Range("A:G").Find(What:="*", After:=Range("A1"), _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious).Row
Dbg = True
If Dbg Then Debug.Print ">>>>> LastR=" & LastR
For I = 8 To LastR
    LastR = Range("A:G").Find(What:="*", After:=Range("A1"), _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
    If I >= LastR Then
        MsgBox ("Completato..." & vbCrLf & "Eliminare manualmente colorazione su Foglio1")
        Exit Sub
    End If
    If Len(Cells(I, "B").Value) > 3 Then
        If IsDate(Cells(I, "B")) Then
            If Dbg Then Debug.Print "Inizio Blocco: " & I
            cLine = I
            bLen = GetLoB(cLine, 2, 1000)
            If Dbg Then Debug.Print "Lungh  Blocco: " & bLen
            If Application.WorksheetFunction.CountA(Cells(cLine, "A").Resize(bLen, 1)) = 0 Then
                Cells(cLine, "B").Resize(bLen, 5).ClearContents
'                If bLen > 1 Then
                    If Dbg Then Debug.Print "Delete lines, n° " & bLen - 0
                    Cells(cLine + 1, "A").Resize(bLen - 0, 7).Delete (xlShiftUp)
'                End If
            Else
                Cells(cLine, "B").Resize(bLen, 5).Select
                If Dbg Then Debug.Print "Ambigua: " & Selection.Address(0, 0)
                MsgBox ("Area selezionata non e' ripulibile automaticamente; pulire manualmente e riprovare")
                Exit Sub
            End If
        End If
    End If
Next I
End Sub


Function GetLoB(ByVal iLine, sCol As Long, Optional lMax As Long = 1000) As Long
Dim Li As Long
For Li = 1 To lMax
    If Len(Cells(iLine + Li, sCol)) < 4 Then Exit For
    If Not IsDate(Cells(iLine + Li, sCol).Value) Then Exit For
Next Li
GetLoB = Li
End Function


Metti tutto su un modulo standard e all'occorrenza lancia Sub Restora

[Ricky0185]

XP - Excel 2003
ma comunque funziona tutto alla perfezione anche se non ho ancora verificato se applicando la macro sul file originale (>2000 righe) resta qualcosa per strada.
Ancora grazie per il tempo dedicatomi ed ovviamente per la soluzione.
Cordiali saluti e Buon WE+Ferragosto.
R

[Ricky0185]

Porca paletta. Con le macro di Anthony dellì11.08 h11.23 e del 13.08 funziona tutto alla perfezione, MA mi sono accorto che solo alcune date del "Copiato" sono a stile inglese e non capisco neppure il criterio con cui vengono scelte quelle da far apparire con quello stile, anche perchè l'ordine delle voci è inalterato.
Il mio portatile (XP + Excel2003) è con sistema data1904 non spuntato, ma anche spuntandolo il problema si ripresenta con date aumentate di un giorno.

Forse nelle macro qualcosa non viene digerito nel modo giusto, ma solo Anthony può individuare il problema, sempre che sia nelle macro.
Non vorrei dover formattare le singole celle con date in stile inglese trasformandole con una formattazione personalizzata in italiano.
Un saluto
R

[Anthony47]

Purtroppo quelle date sono state importate sbagliate e 01/giu/2022 sono diventate 06/gen/2022
Per conferma, formatta come numero la "stessa" date su Foglio1 e su Foglio2, poi dimmi come la leggevi formattata da data e come la leggi formattata da numero.

Credo che la soluzione sia sostituire questa parte

Codice: Seleziona tutto

        For I = 1 To 4
            cArr(I, cInd) = CL.Offset(0, -2 + I).Value
        Next I


con

Codice: Seleziona tutto

        For I = 1 To 4
            If I = 1 Then
                cArr(I, cInd) = CLng(CL.Offset(0, -2 + I).Value)
            Else
                cArr(I, cInd) = CL.Offset(0, -2 + I).Value
            End If
        Next I


Prova e controlla...

[Ricky0185]

Sia formattando come numero le stesse date su Foglio1 e su Foglio2 peima di lanciare la macro e sia sostituendo quella parte di codice, le date vengono trasritte corrette su Foglio2.
Ti ringrazio.
R