Metodo VBA per copiare dati in fogli specifici

Question

ciao a tutti, ho la necessità di suddividere, tramite macro vba, un insieme di dati in fogli specifici. Nel caso specifico, le righe devono essere suddivise per caso specifico. avrei pensato a 2 possibili soluzioni:

1. la prima utilizzando un ciclo Do Until per leggere le righe da copiare e un altro ciclo per incollarle nel foglio specifico
2. la seconda, utilizzare un ciclo applicando di volta in volta il filtro desiderato

Ovvio che la scrittura di queste soluzioni è dispendioso in termini di tempo e,immagino, anche in termini di esecuzione della macro.

Vi chiedo pertanto di suggerirmi una soluzione alternativa, con relativo codice da inserire in vba. Vi riporto un esempio di tipoloigia di dati da suddividere.

grazie

NUMERO	UFFICIO	DT_SCADENZA_CAMBIO_STATO	AGENZIA
007030021017842	60A1	20210901	000627
007030021017894	60A1	20210901	000305
057030021004784	60A1	20210901	001318
057030021004632	60G1	20210901	001056
007030021017615	60L1	20210901	002085
407030021002786	60M1	20210901	400748
007030021017681	60Q1	20210901	000060
037990021002843	60Q1	20210901	009944

Answer 1

Ciao Antonio,

scusami se sono stato superficiale nelle informazioni. nella mia richiesta non ho tenuto conto dei formati. ho creduto che mantenesse quelli di partenza.

dopo aver copiato la tua versione, con qualche piccola modifica, il risultato non è cambiato.

ti allego il file di partenza con relativo codice completo. ho notato, e non capisco quale possa essere l'inghippo, che nel foglio CDL Nord Est, il "CODICE UFFICIO" non resta "60E2" ma cambia in "6000". eppure nella creazione dle foglio CDL lo imposto come Testo. grazie infinite

Dati CDL

Nella tua modifica del mio codice, sostituisci

    With destSH 

        rngIntestazioni.Copy Destination:=.Range("A1") 

        If CBool(iCtr) Then 

              .Range("A2").Resize(iCtr, UBound(arrDati, 2) - 1).Value = Application.Transpose(arrOut) 

            srcSH.Range("A1").CurrentRegion.Copy 

            .Range("A1").CurrentRegion.PasteSpecial Paste:=xlPasteFormats 

            With .UsedRange.Offset(1).Columns(1) 

                .NumberFormat = "0" 

                .Value = .Value 

            End With 

            With .UsedRange.Offset(1).Columns(2) 

                .NumberFormat = "0" 

                .Value = .Value 

            End With 

           Erase arrOut 

        End If 

    End With 

Next i 

Call MsgBox(Prompt:="Fatto", \_ 

    Buttons:=vbInformation, \_ 

    Title:="REPORT") 

esco:

Application.ScreenUpdating = True

End Sub

con:

With destSH

rngIntestazioni.Copy Destination:=.Range("A1")

If CBool(iCtr) Then

.Range("C2").Resize(iCtr).NumberFormat = "@"

.Range("A2").Resize(iCtr, UBound(arrDati, 2) - 1).Value = Application.Transpose(arrOut)

srcSH.Range("A1").CurrentRegion.Copy

.Range("A1").CurrentRegion.PasteSpecial Paste:=xlPasteFormats

With .UsedRange.Offset(1).Columns(1)

.NumberFormat = "0"

.Value = .Value

End With

With .UsedRange.Offset(1).Columns(2)

.NumberFormat = "0"

.Value = .Value

End With

Erase arrOut

End If

End With

Next i

Call MsgBox(Prompt:="Fatto", _

Buttons:=vbInformation, _

Title:="REPORT")

esco:

Application.ScreenUpdating = True

End Sub

===

Regards,

Norman

Answer 2

ciao Norman, ecco la tabella completa della suddivisione dei codici.

grazie

Codice Ufficio	Descrizione
60C2	Nord Est
60E2	Nord Est
60C1	Milano
60A1	Nord Ovest
60B1	Nord Ovest
60N1	Roma
60M1	Centro Adriatico
60M2	Centro Adriatico
60L1	Nord Tirreno
60T3	Nord Tirreno
60T8	Nord Tirreno
60G1	Modena
60R1	Sud Adriatico
60R5	Sud Adriatico
60T1	Sud Tirreno
60T5	Sud Tirreno
60T6	Sud Tirreno
60Q1	Napoli

Answer 3

Ciao Antonio,

grazie Norman per la splendida soluzione. nel frattempo il mio capo mi ha chiesto di raggruppare alcuni codici ufficio. allora ho provato a modificare la tua soluzione nel seguente modo:

Parte precedente ok...non modificata...

On Error GoTo esco
Application.ScreenUpdating = False
For i = 2 To UBound(arrFogli)
sStr = arrFogli(i, 1)
If sStr = "60C2" Or "60E2" Then
sCDL = "Nord Est"
End If
If sStr = "60C1" Then
sCDL = "Milano"
End If
If sStr = "60A1" Or "60B1" Then
sCDL = "Nord Ovest"
End If
If sStr = "60N1" Then
sCDL = "Roma"
End If
If sStr = "60M1" Or "60M2" Then
sCDL = "Centro Adriatico"
End If

'-->> Crea Foglio
With WB
If Not SheetExists(sCDL, WB) Then
Set destSH = .Sheets.Add(After:=.Sheets(.Sheets.Count))
With destSH
.Name = sCDL
.Columns(1).NumberFormat = "@"
rngIntestazioni.Copy
.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
End With
Else
Set destSH = .Sheets(sCDL)
End If
End With
'-->> FINE Crea Foglio

inserendo queste righe, il codice entra sempre nella prima if, nonostante il codice ufficio sia "60A1" continua entra nella if corretta per poi uscire in modo anomalo. in cosa ho sbaglio??? Ovviamente sStr e sCDL sono state definite come string

grazie

Vista la nuova esigenza dettata dalla tua azienda, credo che la logica del mio codice richieda una revisione fondamentale.

Per consentirmi di adattare utilmente il mio codice, ti chiedo di pubblicare una tabella completa delle regioni richieste e dei corrispondenti codici degli uffici.

===

Regards,

Norman

Answer 4

grazie Norman per la splendida soluzione. nel frattempo il mio capo mi ha chiesto di raggruppare alcuni codici ufficio. allora ho provato a modificare la tua soluzione nel seguente modo:

Parte precedente ok...non modificata...

On Error GoTo esco  
Application.ScreenUpdating = False  
For i = 2 To UBound(arrFogli)  
    sStr = arrFogli(i, 1)  
    If sStr = "60C2" Or "60E2" Then  
        sCDL = "Nord Est"  
    End If  
    If sStr = "60C1" Then  
       sCDL = "Milano"  
    End If  
    If sStr = "60A1" Or "60B1" Then  
       sCDL = "Nord Ovest"  
    End If  
    If sStr = "60N1" Then  
       sCDL = "Roma"  
    End If  
    If sStr = "60M1" Or "60M2" Then  
       sCDL = "Centro Adriatico"  
    End If

'-->> Crea Foglio
With WB
If Not SheetExists(sCDL, WB) Then
Set destSH = .Sheets.Add(After:=.Sheets(.Sheets.Count))
With destSH
.Name = sCDL
.Columns(1).NumberFormat = "@"
rngIntestazioni.Copy
.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
End With
Else
Set destSH = .Sheets(sCDL)
End If
End With
'-->> FINE Crea Foglio

inserendo queste righe, il codice entra sempre nella prima if, nonostante il codice ufficio sia "60A1" continua entra nella if corretta per poi uscire in modo anomalo. in cosa ho sbaglio??? Ovviamente sStr e sCDL sono state definite come string

grazie

Answer 5

Ciao Antonio,

ciao a tutti, ho la necessità di suddividere, tramite macro vba, un insieme di dati in fogli specifici. Nel caso specifico, le righe devono essere suddivise per caso specifico. avrei pensato a 2 possibili soluzioni:

1. la prima utilizzando un ciclo Do Until per leggere le righe da copiare e un altro ciclo per incollarle nel foglio specifico
2. la seconda, utilizzare un ciclo applicando di volta in volta il filtro desiderato

Ovvio che la scrittura di queste soluzioni è dispendioso in termini di tempo e,immagino, anche in termini di esecuzione della macro.

Vi chiedo pertanto di suggerirmi una soluzione alternativa, con relativo codice da inserire in vba. Vi riporto un esempio di tipoloigia di dati da suddividere.

NUMERO	UFFICIO	DT_SCADENZA_CAMBIO_STATO	AGENZIA
007030021017842	60A1	20210901	000627
007030021017894	60A1	20210901	000305
057030021004784	60A1	20210901	001318
057030021004632	60G1	20210901	001056
007030021017615	60L1	20210901	002085
407030021002786	60M1	20210901	400748
007030021017681	60Q1	20210901	000060
037990021002843	60Q1	20210901	009944

Poiché stai utilizzando Excel 365, potresti ottenere i risultati desiderati in modo dinamico con una semplice formula del tipo:

=FILTRO(Tabella_Dati;Tabella_Dati[UFFICIO]=STRINGA.ESTRAI(CELLA("filename";A1);TROVA("]";CELLA("filename";A1))+1;255))

dove i dati iniziali si trovano in una tabella Excel denominata Tabella_Dati.

Per testarla, seleziona (raggruppa) i fogli di destinazione di interesse, inseririsci la formula e premi invio.

Puoi scaricare il mio file di prova Antonio20210811.xlsx

Tuttavia, dato che hai richiesto una soluzione VBA, prova qualcosa del genere:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

Dim WB As Workbook 

Dim SH As Worksheet, srcSH As Worksheet, destSH As Worksheet 

Dim srcRng As Range, destRng As Range, rngIntestazioni As Range

Dim arrDati As Variant, arrFogli As Variant, arrOut() As Variant 

Dim sStr As String 

Dim i As Long, j As Long, k As Long, iCtr As Long 

Const sFoglio\_Sorgente As String = **"Foglio1"         '<<=== Modifica** 

Set WB = ThisWorkbook 

Set srcSH = WB.Sheets(sFoglio\_Sorgente) 

Set srcRng = srcSH.Range("A1").CurrentRegion.Resize(, 4) 

Set rngIntestazioni = srcRng.Rows(1) 

arrDati = srcRng.Value 

arrFogli = srcRng.Columns(2).Value 

On Error GoTo XIT 

Application.ScreenUpdating = False 

For i = 2 To UBound(arrFogli) 

    sStr = arrFogli(i, 1) 

    iCtr = 0 

    With WB 

        If Not SheetExists(sStr, WB) Then 

            Set destSH = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 

            With destSH 

                .Name = sStr 

                .Columns(1).NumberFormat = "@" 

                rngIntestazioni.Copy 

                .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths 

            End With 

        Else 

            Set destSH = .Sheets(sStr) 

        End If 

    End With 

    For j = 2 To UBound(arrDati) 

        If arrDati(j, 2) = sStr Then 

            iCtr = iCtr + 1 

            ReDim Preserve arrOut(1 To 4, 1 To iCtr) 

            For k = 1 To UBound(arrDati, 2) 

                arrOut(k, iCtr) = arrDati(j, k) 

            Next k 

        End If 

    Next j 

    With destSH 

        rngIntestazioni.Copy Destination:=.Range("A1") 

        .Range("A2").Resize(iCtr, UBound(arrDati, 2)).Value = Application.Transpose(arrOut) 

        .Columns("B:C").HorizontalAlignment = xlCenter 

        Erase arrOut 

    End With 

Next i 

    Call MsgBox(Prompt:="Fatto", \_ 

    Buttons:=vbInformation, \_ 

    Title:="REPORT") 

XIT:

Application.ScreenUpdating = True

End Sub

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

Public Function SheetExists(sSheetName As String, _

Optional ByVal WB As Workbook) As Boolean 

On Error Resume Next 

If WB Is Nothing Then 

    Set WB = ThisWorkbook 

End If 

SheetExists = CBool(Len(WB.Sheets(sSheetName).Name)) 

End Function

'<<========

Potresti scaricare il mio file di prova Antonio20210811.xlsm

===

Regards,

Norman