Condividi tramite

Trovare SOLO i nuovi clienti in base alla data

Anonimo
2015-06-15T10:02:17+00:00

Buongiorno again, oggi sono di modifiche dei files che normalmente utilizzo per lavoro, quindi pericoloso!!

Nell'elenco devo trovare solo i nuovi clienti indipendentemente dall'anno del primo contatto e una volta acquisito è acquisito. I dati d'origine sono sul Foglio1, mentre quelli di destinazione sul Foglio2.

Di seguito una rappresentazione di quello che mi servirebbe. Grazie, que pase un bon dia!

SU FOGLIO 1
cliente importo N° Fatt data
franco 100,00 22 22-gen-15**
franco 2.000,00 23 22-feb-15
franco 3.000,00 24 23-mar-15
gianni 100,00 1 22-gen-14
gianni 200,00 2 22-gen-15
luca 100,00 4 22-mar-15
luca 200,00 5 15-mag-15
luca g 300,00 7 12-giu-13*
luca g 300,00 8 12-mag-15
gianni g 300,00 12 22-giu-13*
gianni g 300,00 18 12-apr-14
alex 22,00 1 12-gen-15**
alex 44,00 2 13-mar-15
SU FOGLIO 2
giugno-13 gennaio-14 gennaio-15 marzo-15
NUOVI CLIENTI 2 * 1 2 ** 1
Microsoft 365 e Office | Excel | Per la casa | Windows

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo
2015-06-15T12:40:01+00:00

Uhm... Prova così:

' Standard Module : Modulo1

'

Option Explicit

Public Sub ListaNuoviClientiAnnoMese()

On Error GoTo ErrH

Const cstrWsh       As String = "Foglio1"

Const cstrRng       As String = "A1"

Const clngCliOffset As Long = 3

Const cstrWshNew    As String = "Risultato"

Dim wsh       As Excel.Worksheet

Dim rng       As Excel.Range

Dim colCli    As VBA.Collection

Dim r         As Long

Dim e         As Long

Dim strKey    As String

Dim strItem   As String

Dim i         As Long

Dim colDate   As VBA.Collection

Dim lngCount  As Long

      Set wsh = ThisWorkbook.Worksheets(cstrWsh)

      With wsh

        Set rng = .Range(.Range(cstrRng), _

                         .Cells(.Rows.Count, _

                                .Range(cstrRng).Column _

                                ).End(xlUp))

      End With

      If rng.Rows.Count = 1 Then

        MsgBox "Nessun dato."

        GoTo ExtP

      End If

      Set colCli = New VBA.Collection

      For r = 1 To rng.Count - 1

        With rng

          strKey = "K" & .Offset(r).Resize(1).Value

          strItem = Format$(.Offset(r, clngCliOffset).Resize(1).Value, _

                            "yyyy-mm")

        End With

        On Error Resume Next

        With colCli

          .Add strItem, strKey

          e = Err.Number

          On Error GoTo ErrH

          If e Then

            If .Item(strKey) > strItem Then

              .Remove strKey

              .Add strItem, strKey

            End If

          End If

        End With

      Next

      Set colDate = New VBA.Collection

      For i = 1 To colCli.Count

        With colCli

          strKey = "K" & .Item(i)

          strItem = .Item(i)

        End With

        With colDate

          On Error Resume Next

          .Add Array(strItem, 1), strKey

          e = Err.Number

          On Error GoTo ErrH

          If e Then

            strItem = .Item(strKey)(0)

            lngCount = .Item(strKey)(1) + 1

            .Remove strKey

            .Add Array(strItem, lngCount), strKey

          End If

        End With

      Next

      Application.DisplayAlerts = False

      With ThisWorkbook.Worksheets

        On Error Resume Next

        .Item(cstrWshNew).Delete

        On Error GoTo ErrH

        With .Add

          .Name = cstrWshNew

          .Range("A2").Value = "NUOVI CLIENTI"

          For i = 1 To colDate.Count

            With .Range("A1")

              With .Offset(0, i)

                .Value = DateValue(colDate(i)(0) & "-01")

                .NumberFormat = "yyyy-mm"

              End With

              .Offset(1, i).Value = colDate(i)(1)

            End With

          Next

          With .Sort

            With .SortFields

              .Clear

              .Add Key:=Range("B1").Resize(1, colDate.Count), _

                   SortOn:=xlSortOnValues, _

                   Order:=xlAscending, _

                   DataOption:=xlSortNormal

            End With

            .SetRange Range("B1").Resize(2, colDate.Count)

            .Header = xlNo

            .Orientation = xlLeftToRight

            .Apply

          End With

          .Columns.AutoFit

          .Range("A1").Select

        End With

      End With

ExtP: On Error Resume Next

      Application.DisplayAlerts = True

      Set colDate = Nothing

      Set colCli = Nothing

      Set rng = Nothing

      Set wsh = Nothing

      On Error GoTo 0

      Exit Sub

ErrH: MsgBox Err.Description

      Resume ExtP

End Sub

La risposta è stata utile?

0 commenti

10 risposte aggiuntive

Ordina per: Più utili
Più utili Più recente Meno recente
  1. Anonimo
    2015-06-15T13:57:34+00:00

    I N C R E D I B I L E

    Macro Stupenda! Grazie 1000, bella "spessa", quando la lancio il pc si blocca un pò!!

    Grazie di cuore, per oggi nn rompo più, promesso

    A

    Ho apportato le modifiche in neretto:

    ' Standard Module : Modulo1

    '

    Option Explicit

    Public Sub ListaNuoviClientiAnnoMese()

    On Error GoTo ErrH

    Const cstrWsh       As String = "Dati_Fatt"

    Const cstrRng       As String = "A1"

    Const clngCliOffset As Long = 4 '(perché ho spostato/aggiunto una colonna)

    Const cstrWshNew    As String = "Risultato"

    Dim wsh       As Excel.Worksheet

    Dim rng       As Excel.Range

    Dim colCli    As VBA.Collection

    Dim r         As Long

    Dim e         As Long

    Dim strKey    As String

    Dim strItem   As String

    Dim i         As Long

    Dim colDate   As VBA.Collection

    Dim lngCount  As Long

          Set wsh = ThisWorkbook.Worksheets(cstrWsh)

          With wsh

            Set rng = .Range(.Range(cstrRng), _

                             .Cells(.Rows.Count, _

                                    .Range(cstrRng).Column _

                                    ).End(xlUp))

          End With

          If rng.Rows.Count = 1 Then

            MsgBox "Nessun dato."

            GoTo ExtP

          End If

          Set colCli = New VBA.Collection

          For r = 1 To rng.Count - 1

            With rng

              strKey = "K" & .Offset(r).Resize(1).Value

              strItem = Format$(.Offset(r, clngCliOffset).Resize(1).Value, _

                                "yyyy-mm")

            End With

            On Error Resume Next

            With colCli

              .Add strItem, strKey

              e = Err.Number

              On Error GoTo ErrH

              If e Then

                If .Item(strKey) > strItem Then

                  .Remove strKey

                  .Add strItem, strKey

                End If

              End If

            End With

          Next

          Set colDate = New VBA.Collection

          For i = 1 To colCli.Count

            With colCli

              strKey = "K" & .Item(i)

              strItem = .Item(i)

            End With

            With colDate

              On Error Resume Next

              .Add Array(strItem, 1), strKey

              e = Err.Number

              On Error GoTo ErrH

              If e Then

                strItem = .Item(strKey)(0)

                lngCount = .Item(strKey)(1) + 1

                .Remove strKey

                .Add Array(strItem, lngCount), strKey

              End If

            End With

          Next

          Application.DisplayAlerts = False

          With ThisWorkbook.Worksheets

            On Error Resume Next

            .Item(cstrWshNew).Delete

            On Error GoTo ErrH

            With .Add

              .Name = cstrWshNew

              .Range("A2").Value = "NUOVI CLIENTI"

              For i = 1 To colDate.Count

                With .Range("A1")

                  With .Offset(0, i)

                    .Value = DateValue(colDate(i)(0) & "-01")

                    .NumberFormat = "yyyy-mm"

                  End With

                  .Offset(1, i).Value = colDate(i)(1)

                End With

              Next

              With .Sort

                With .SortFields

                  .Clear

                  .Add Key:=Range("B1").Resize(1, colDate.Count), _

                       SortOn:=xlSortOnValues, _

                       Order:=xldecending, _ '(per un ordinamento inverso)

                       DataOption:=xlSortNormal

                End With

                .SetRange Range("B1").Resize(2, colDate.Count)

                .Header = xlNo

                .Orientation = xlLeftToRight

                .Apply

              End With

              .Columns.AutoFit '(che finezza, Grazie)

              .Range("A1").Select

            End With

          End With

    Rows("1:1").Select

    Selection.NumberFormat = "[$-410]mmmm-yy;@"

    '(aggiunto per cambiare la formattazione, nn ho trovato altro modo)

    ExtP:  On Error Resume Next

          Application.DisplayAlerts = True

          Set colDate = Nothing

          Set colCli = Nothing

          Set rng = Nothing

          Set wsh = Nothing

          On Error GoTo 0

          Exit Sub

    ErrH: MsgBox Err.Description

          Resume ExtP

        End Sub

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2015-06-15T13:53:53+00:00

    E se ci fossero nuovi clienti anche in altre date dove li collocheresti nel foglio2?

    La risposta è stata utile?

    0 commenti
  3. Anonimo
    2015-06-15T13:15:35+00:00

    Cerca di individuare la riga in cui ottieni l'errore eseguendo passo passo. Alt+F11, seleziona una istruzione dopo "Public sub ..." e premi F8 lentamente e ripetutamente in modo da vedere qual è l'istruzione che fa saltare al gestore errori.

    La risposta è stata utile?

    0 commenti
  4. Anonimo
    2015-06-15T12:59:00+00:00

    quando lancio la Mega macro mi dice "tipo non corrispondente"...

    La risposta è stata utile?

    0 commenti