![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
Microsoft 365 e Office | Excel | Per la casa | Windows
Una famiglia di software per fogli di calcolo Microsoft con strumenti per l'analisi, la creazione di grafici e la comunicazione dei dati.
Vorrei sapere se qualcuno può aiutarmi per un problema che non riesco a risolvere.
Ho due colonne anzi quattro:
A B C D
Arancio descrizione 1 Bianco descrizione 2
Bianco descrizione 2 Giallo descrizione 3
Giallo descrizione 3 Nero descrizione 5
Marrone descrizione 4 Rosso descrizione 6
Nero descrizione 5
Rosso descrizione 6
Verde descrizione 7
Vorrei come recita il titolo riuscire ad "affiancare" (anche se non è il termine corretto) le celle delle colonne "A+B" con quelle di "C+D" nei casi in cui A è uguale a C. Per giungere a una cosa come sotto:
A B C D
Arancio descrizione 1 "cella vuota"
Bianco descrizione 2 Bianco descrizione 2
Giallo descrizione 3 Giallo descrizione 3
Marrone descrizione 4 "cella vuota"
Nero descrizione 5 Nero descrizione 5
Rosso descrizione 6 Rosso descrizione 6
Verde descrizione 7 "cella vuota".
Qualcuno può aiutarmi.
Grazie
Ciao Luca,
Prpva qualcosa del genere:
Alt-F11 per aprire l'Editor di VBA
Menu | Inserisci | Modulo
Incolla il suddetto codice
'=============>>
Option Explicit
'------------->>
Private Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim RngA As Range
Dim RngB As Range
Dim destRng As Range
Dim iLastRow As Long
Dim jLastRow As Long
Dim i As Long, j As Long
Dim arrA() As Variant
Dim arrB() As Variant
Set WB = Workbooks("Pippo.xlsx") '<<=== Cambia
Set SH = WB.Sheets("Foglio1") '<<=== Cambia
With SH
iLastRow = LastRow(SH, SH.Columns("A:A"))
jLastRow = LastRow(SH, SH.Columns("C:C"))
Set RngA = .Range("A2:B" & iLastRow)
Set RngB = .Range("C2:D" & jLastRow)
Set destRng = .Range("A2")
End With
arrA = RngA.Value
ReDim Preserve arrA(1 To iLastRow - 1, 1 To 4)
arrB = RngB.Value
For i = LBound(arrA, 1) To UBound(arrA, 1)
For j = LBound(arrB, 1) To UBound(arrB, 1)
If arrB(j, 1) = arrA(i, 1) Then
arrA(i, 3) = arrB(j, 1)
arrA(i, 4) = arrB(j, 2)
End If
Next j
Next i
Set destRng = RngA.Cells(1).Resize(UBound(arrA, 1), 4)
destRng.Value = arrA
End Sub
'------------->>
Function LastRow(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If
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
End Function
'<<=============
Alt-Q per chiudere l'editor di VBA e tornare in Excel
Alt -F8 per aprire la finistrina di macro
Seleziona Tester
Esegui
Salva il file come tipo xlsm.
===
Regards,
Norman