Unire più celle di colonne in un unica riga

Question

Buongiorno, Ho un file dove in una colonna ci sono molti duplicati, ma non posso eliminare perchè ogni riga ha dei dati diversi, come faccio ad unire tutti i dati diversi in un unica riga? Spero di essere stata chiara, allego un file per intenderci.

In pratica dovrei inserire su un unica riga tutti i dati della colonna B che hanno in comune di dati della colonna A.

COLONNA A (codice fiscale)	COLONNA B (point)
BBCRCF75C25F839A	IT001E0000000
BBCRCF75C25F839A	00352555881122
BBCRCF75C25F839A	IT001E0012000
BBCRCF75C25F839A	00357586881122

Spero che possiate aiutarmi.

Answer 1

Ciao  Rosaria_D.M.,

Buongiorno, Ho un file dove in una colonna ci sono molti duplicati, ma non posso eliminare perchè ogni riga ha dei dati diversi, come faccio ad unire tutti i dati diversi in un unica riga? Spero di essere stata chiara, allego un file per intenderci.

In pratica dovrei inserire su un unica riga tutti i dati della colonna B che hanno in comune di dati della colonna A.

 

COLONNA A (codice fiscale)	COLONNA B (point)
BBCRCF75C25F839A	IT001E0000000
BBCRCF75C25F839A	00352555881122
BBCRCF75C25F839A	IT001E0012000
BBCRCF75C25F839A	00357586881122

Spero che possiate aiutarmi.

Partendo dal presupposto che potrebbe esserci un numero elevato di codici fiscali da gestire, prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IMper inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim arrIn As Variant, arrOut As Variant

    Dim arrCodiceFiscale As Variant

    Dim arrKeys As Variant, arrItems As Variant

    Dim arrSplit As Variant

    Dim oDic As Object

    Dim sCodice As String, sPoint As String

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

    Dim LRow As Long, UB As Long, iMax As Long

    Dim CalcMode As Long

    Const sFoglioDati As String = "Foglio1"     '<<=== Modifica

    Const sFoglioReport As String = "Report"   '<<=== Modifica

    Set WB = ThisWorkbook

    With WB

        Set srcSH = WB.Sheets(sFoglioDati)

        If SheetExists(sFoglioReport) Then

            Set destSH = .Sheets(sFoglioReport)

            destSH.UsedRange.Offset(1).ClearContents

        Else

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

            destSH.Name = sFoglioReport

        End If

    End With

    With srcSH

        LRow = LastRow(srcSH, .Columns("A:A"))

        Set srcRng = .Range("A2:B" & LRow)

    End With

    arrIn = srcRng.Value

    Set oDic = CreateObject("Scripting.Dictionary")

    With oDic

        .CompareMode = vbTextCompare

        For i = LBound(arrIn) To UBound(arrIn)

            sCodice = arrIn(i, 1)

            sPoint = arrIn(i, 2)

            If Not .exists(sCodice) Then

                .Add Key:=sCodice, Item:=sPoint

            Else

                .Item(sCodice) = .Item(sCodice) & vbNewLine & sPoint

            End If

        Next i

        arrKeys = .Keys

        arrItems = .Items

        ReDim arrOut(1 To .Count, 1 To UBound(arrIn))

        For j = 1 To .Count

            arrOut(j, 1) = arrKeys(j - 1)

            arrSplit = Split(arrItems(j - 1), vbNewLine)

            UB = UBound(arrSplit) + 1

            If UB > iMax Then

                iMax = UB

            End If

            For k = 1 To UB

                arrOut(j, k + 1) = arrSplit(k - 1)

            Next k

        Next j

    End With

    ReDim Preserve arrOut(1 To UBound(arrOut), 1 To iMax)

    On Error GoTo XIT

    Application.ScreenUpdating = False

    Set destRng = destSH.Range("A2").Resize(UBound(arrOut), iMax)

    With destRng

        .NumberFormat = "@"

        .Value = arrOut

        .EntireColumn.AutoFit

    End With

        Call MsgBox( _

             Prompt:="Finito", _

             Buttons:=vbInformation, _

             Title:="REPORT")

XIT:

  Application.ScreenUpdating = True

End Sub

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

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       After:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

End Function

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

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))

    On Error GoTo 0

End Function

'<<========= 

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester
• Esegui

Potresti scaricare il mio file di prova Rosaria20180717.xlsm

In questo file, potresti creare il report premendo il pulsante rosa:

===

Regards,

Norman