Creare tanti fogli per ogni riga di un foglio

Question

Buongiorno, ricevo da un fornitore il packing-list come sotto (foglio chiamato Ct1)

Il numero di righe è variabile.

Avrei la necessità di creare, per ogni riga contentente il numero del collo (es 309779) un foglio come sotto (foglio chiamato Label)

e riportare in automatico il nome dell' articolo, lo spessore, il numero del collo, la quantità, i CBM.

Ho creata questa MACRO:

>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Sub CreaEtichette()

Dim foglioCt1 As Worksheet

Dim Label As Worksheet

Dim lunghezza As Integer

Set foglioCt1 = ActiveWorkbook.Worksheets("Ct1")

Set Label = ActiveWorkbook.Worksheets("Label")

lunghezza = WorksheetFunction.CountA(foglioCt1.Columns(1))

For i = 2 To lunghezza

'compilare il nr colli 

Label.Cells(20, 1) = foglioCt1.Cells(i, 1) 

'compilare la quantità 

Label.Cells(20, 2) = foglioCt1.Cells(i, 6) 

'compilare il volume 

Label.Cells(20, 3) = foglioCt1.Cells(i, 7) 

Next i

End Sub

>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

Non so come inserire:

di creare tanti fogli quanti sono le righe del foglio Ct1 e solo per le righe dove c'è valorizzata la colonna "quantità";

di compilare il nome dell' articolo, copiandolo dal foglio Ct1 (righe variabili) e inserendolo nel foglio Label alla cella B16

di compilare lo spessore copiandolo dalla colonna C del foglio Ct1 e inserendolo nella cella C16 del foglio Label

di saltare le righe con i totali nel foglio Ct1.

Grazie in anticipo per l'aiuto.

Morena

Answer 1

Ciao MorenaG,

non avendo a disposizione il file excel ho provato a replicarne la struttura dei due fogli e, sperando che corrisponda alla tua situazione reale, ho provato a scrivere una procedura che legga le righe del foglio "Ct1", e duplichi il foglio "Label" per il numero di "PACKAGES" per cui sia presente un valore "QUANTITA'" assegnando ai nuovi fogli il nome del "PACKAGES".

Vedi se restituisce quanto desiderato e se ti può essere da spunto per il tuo lavoro: File esempio

Questo il codice VBA presente nel Modulo1:

Option Explicit

Sub CreaLabel()

Dim wsCt1 As Worksheet

Dim wsLabel As Worksheet

Dim rngDati As Range

Dim r As Range

Dim sNomeArticolo As String

Dim dSPESSORE As Double

Dim sPACKAGES As String

Dim dQUANTITY_PCE As Double

Dim dQUANTITY_CBM As Double

Dim NewLabel As Worksheet

Application.ScreenUpdating = False

With ThisWorkbook

  Set wsCt1 = .Worksheets("Ct1") 

  Set wsLabel = .Worksheets("Label") 

End With

With wsCt1

  Set rngDati = Intersect(.UsedRange, .Columns("A:G"), .Rows("7:1048576")) 

  For Each r In rngDati.Columns(1).Cells 

        If r.MergeArea.Columns.Count = .Columns("A:G").Columns.Count Then 

           sNomeArticolo = r.Value 

        Else 

           If r.Offset(0, 5).Value <> "QUANTITA'" And r.Offset(0, 5).Value <> "" Then 

              sPACKAGES = r.Value 

              dSPESSORE = r.Offset(0, 2).Value 

              dQUANTITY\_PCE = r.Offset(0, 5).Value 

              dQUANTITY\_CBM = r.Offset(0, 6).Value 

              If Not SheetExists(sPACKAGES) Then 

                 wsLabel.Copy After:=Sheets(Sheets.Count) 

                 Set NewLabel = Worksheets(Sheets.Count) 

                 NewLabel.Name = sPACKAGES 

              Else 

                 Set NewLabel = Worksheets(sPACKAGES) 

              End If 

              With NewLabel 

                 .Range("B16").Value = sNomeArticolo 

                 .Range("C16").Value = dSPESSORE 

                 .Range("A20").Value = sPACKAGES 

                 .Range("B20").Value = dQUANTITY\_PCE 

                 .Range("C20").Value = dQUANTITY\_CBM 

              End With 

           End If 

        End If 

  Next r 

End With

wsCt1.Activate

Application.ScreenUpdating = True

End Sub

Public Function SheetExists(sSheetName As String, _

                        Optional ByVal Wb As Workbook) As Boolean 

'by Norman Devid Jones 

On Error Resume Next 

If Wb Is Nothing Then 

    Set Wb = ThisWorkbook 

End If 

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

End Function

Answer 2

Ciao, scusa se rispondo solo, ma non ho avuto modo di testarlo prima.
Funziona alla grande. Mi sei stato davvero di aiuto.

Ti ringrazio.

Answer 3

Scusa il disturbo. Sfortunatamente, non c'è stato alcun feedback da parte vostra. Hai ancora bisogno di aiuto?

Answer 4

Ciao,

probabilmente non hai copiato nel modulo VBA la funzione presente nel file di esempio che serve per verificare se un foglio nominato in un determinato modo è già esistente.

Si tratta di questa funzione

Public Function SheetExists(sSheetName As String, _

                        Optional ByVal Wb As Workbook) As Boolean 

'by Norman Devid Jones 

On Error Resume Next 

If Wb Is Nothing Then 

    Set Wb = ThisWorkbook 

End If 

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

End Function

Answer 5

***La risposta è stata tradotta automaticamente. Di conseguenza, potrebbero esserci errori grammaticali o parole insolite.***

Ciao, MorenaG!

Sono molto felice di darti il benvenuto nel nostro forum.

I nostri colleghi del forum tecnico specializzato in Excel possono aiutarti in questo compito: Excel (microsoft.com) (English)

Cordiali saluti,

Anton.