Scegliere tra valori uguali

Option Explicit

Sub CopiaTabella()
Dim Cnt As Long, mRng As Range, Occurrence As Long, lCol1 As Long, lCol2 As Long
Dim rTab As Long, LastR As Long, c As Object, firstaddress As String, DelFrom As Long
Const ToFind As String = "#"
Set mRng = Range("B:B")
Occurrence = 2
Cnt = 0
With mRng
    Set c = .Find(ToFind, LookIn:=xlValues, lookat:=xlWhole)
    If Not c Is Nothing Then
        firstaddress = c.Address
        lCol1 = Cells(c.Row, 2).End(xlToRight).Column
        Do
            Cnt = Cnt + 1
            rTab = c.Row
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
    End If
End With
If Cnt = 2 Then
    lCol2 = Cells(rTab, 2).End(xlToRight).Column
    DelFrom = Application.WorksheetFunction.Max(lCol1, lCol2) + 2
    Range(Cells(1, DelFrom), Cells(Rows.Count, Columns.Count)).ClearContents
    LastR = Range("B" & rTab).End(xlDown).Row
    Range(Cells(rTab, 2), Cells(LastR, lCol2)).Copy
    Cells(4, DelFrom).PasteSpecial
    Range(Cells(rTab, 2), Cells(LastR, lCol2)).ClearContents
    If DelFrom - lCol1 > 2 Then
        Range(Cells(1, lCol1 + 1), Cells(Rows.Count, DelFrom - 2)).Delete Shift:=xlToLeft
    End If
    Application.Goto Range("A1"), True
    Exit Sub
End If
MsgBox "tabella non trovata"
End Sub