Copia un numero univoco di righe separate da una riga vuota

Question

. Ciao!

Ho un lungo elenco con i nomi dei clienti (> 500 righe, 12 colonne), separati da una riga vuota. Assomiglia a questo:

Ho bisogno di copiare tutte le righe per ogni cliente univoco (ad esempio "Peter") su un altro foglio. Ho provato a registrare una macro e ho usato combinazioni di ctrl e shift con le frecce su / giù / destra per copiare i valori per ogni cliente e poi passare ai clienti successivi.

Ho provato a generare un codice generico per i primi tre clienti nella lista (Peter, Adam, Sara) e incollare i valori in un altro foglio. Ho il seguente codice:

Sub COPY_CUSTOMERS()
'
' COPY_CUSTOMERS Makro
'

'
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Sheet(2)").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A8").Select
    Sheets("Customers").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet(2)").Select
    ActiveSheet.Paste
    Sheets("Customers").Select
    Selection.End(xlDown).Select
    
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet(2)").Select
    Range("A10").Select
    ActiveSheet.Paste
    Sheets("Customers").Select
    Selection.End(xlDown).Select
End Sub

Per i clienti che compaiono solo in una riga, non è possibile applicare il codice seguente:

Range(Selection, Selection.End(xlDown)).Select

Quindi non sono sicuro di come risolvere questo problema, selezionare valori univoci poiché i numeri di riga sono sempre diversi.

Sarei molto grato per qualsiasi aiuto o suggerimento.

Grazie e distinti saluti,

QuarterlyReport

Answer 1

Sembra che tu voglia ogni cliente su un foglio separato.

Dato che vedo le frecce giù nella riga superiore, ho supposto che i tuoi dati siano in una tabella (ListObject in VBA). In caso contrario, il codice potrebbe richiedere alcune modifiche.

Ho anche fatto altre ipotesi

Algoritmo

• creare un elenco univoco di clienti utilizzando un oggetto dizionario
• Filtra la tabella per ogni cliente
  • Scrivi le celle visibili nel foglio di lavoro del cliente
  • Ho assunto che il nome del foglio di lavoro del cliente sia lo stesso del nome del cliente
  • Se quel foglio non esiste, verrà creato.
  • La destinazione da incollare è impostata su A9
    • Ma se qualcosa è stato precedentemente incollato lì, incolleremo sotto i dati correnti, omettendo la riga di intestazione.

Option Explicit
Sub splitCustomersToSheets()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim LO As ListObject, dCust As Object
    Dim v, w, C As Range
    
Set dCust = CreateObject("Scripting.Dictionary")
    dCust.comparemode = vbTextCompare 'case insensitive
    
Set wsSrc = Worksheets("Sheet2")
Set LO = wsSrc.ListObjects("tblCustomers") 'or whatever

'Generate list of customers
'faster to loop through vba array than through range on the worksheet
v = LO.DataBodyRange.Columns(2)
For Each w In v
    Select Case w <> ""
        Case True
            If Not dCust.exists(w) Then dCust.Add w, w
    End Select
Next w

'Copy each name to it's own worksheet
For Each v In dCust.keys

    'if worksheet not present, add it
    On Error Resume Next
    Set wsDest = Worksheets(v)
    Select Case Err.Number
        Case 9
             ThisWorkbook.Worksheets.Add
             ActiveSheet.Name = v
             Set wsDest = Worksheets(v)
        Case Is <> 0
            MsgBox "Error Number: " & Err.Number & vbLf & Err.Description
            Exit Sub
    End Select
    On Error GoTo 0
    
    With wsDest
    Set C = .Cells(9, 1)
        If C <> "" Then 'already stuff on the page, paste below range
            Set C = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    End With
    
    'copy the data
    LO.AutoFilter.ShowAllData
    LO.Range.AutoFilter Field:=2, Criteria1:=v
    
    'if sheet not empty, then don't copy the header row
    If C.Row = 9 Then
        LO.Range.SpecialCells(xlCellTypeVisible).Copy C
    Else
        LO.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy C
    End If
        
Next v

End Sub

Se i tuoi dati NON sono in una vera tabella Excel, puoi provare invece questo codice:

Option Explicit
Sub splitCustomersToSheets()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim R As Range, dCust As Object
    Dim v, w, C As Range
    Dim lR As Long, lC As Long
    
Set dCust = CreateObject("Scripting.Dictionary")
    dCust.comparemode = vbTextCompare 'case insensitive
    
Set wsSrc = Worksheets("Sheet2")
With wsSrc
    lR = .Cells(.Rows.Count, 1).End(xlUp).Row
    lC = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set R = .Range(.Cells(1, 1), .Cells(lR, lC))
End With
    
'Generate list of customers
'faster to loop through vba array than through range on the worksheet
v = R.Columns(2).Offset(1, 0)
For Each w In v
    Select Case w <> ""
        Case True
            If Not dCust.exists(w) Then dCust.Add w, w
    End Select
Next w

'Copy each name to it's own worksheet
For Each v In dCust.keys

    'if worksheet not present, add it
    On Error Resume Next
    Set wsDest = Worksheets(v)
    Select Case Err.Number
        Case 9
             ThisWorkbook.Worksheets.Add
             ActiveSheet.Name = v
             Set wsDest = Worksheets(v)
        Case Is <> 0
            MsgBox "Error Number: " & Err.Number & vbLf & Err.Description
            Exit Sub
    End Select
    On Error GoTo 0
    
    With wsDest
    Set C = .Cells(9, 1)
        If C <> "" Then 'already stuff on the page, paste below range
            Set C = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    End With
    
    'copy the data
    Application.ScreenUpdating = False
    On Error Resume Next 'in case no filter is set
        wsSrc.ShowAllData
    On Error GoTo 0
    R.AutoFilter Field:=2, Criteria1:=v
    
    'if sheet not empty, then don't copy the header row
    If C.Row = 9 Then
        R.SpecialCells(xlCellTypeVisible).Copy C
    Else
        R.Offset(1, 0).Resize(R.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy C
    End If
        
Next v

End Sub

Answer 2

Ciò presuppone che i fogli di destinazione esistano già:

Sub croupier()
    Dim N As Long, i As Long, j As Long
    
    N = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To N
        v = Cells(i, "B").Value
        If v <> "" Then
            j = Sheets(v).Cells(Rows.Count, "A").End(xlUp).Row + 1
            Cells(i, 1).EntireRow.Copy Sheets(v).Cells(j, 1)
        End If
    Next i
End Sub

Se i fogli di destinazione hanno una riga di intestazione, non verrà sovrascritta.