Macro TROVA e SOSTITUISCI Celle Correlate

Question

Salve a tutti,

come posso impostare il codice VBA di una macro che risolva il seguente problema?

Ho 3 colonne.

COLONNA A -> Lista di 15.000 prodotti ripetuti

COLONNA B -> Lista di 250 prodotti della COLONNA A (Non Ripetuti)

COLONNA C -> Copia della Lista dei 250 prodotti della COLONNA B (Valori Corretti Manualmente)

Io devo creare una macro che vada a cercare ogni valore della COLONNA B nella COLONNA A e che sostituisca ad ognuno dei valori trovati il Valore Corretto della COLONNA C.

Es. Cerca nel Range A1:A15000 tutti i valori uguali al valore B1 e sostituisci a questi il corrispettivo valore nella cella C1.

Il tutto deve essere in un ciclo che prenda tutti i valori nel Range B1:B250e li sostituisca con quelli del Range C1:C250.

Vi ringrazio anticipatamente!

Answer 1

Ciao francisleroy,

un modo potrebbe essere anche questo:

' Module : Modulo1

'

Option Explicit

Public Sub aTest()

On Error GoTo ErrH

Const cstrCnn   As String = "Provider=Microsoft.ACE.OLEDB.12.0;" & _

                            "Extended Properties=""Excel 12.0;HDR=NO"";" & _

                            "Data Source=<DATASOURCE>;"

Const cstrTblA  As String = "[Foglio1$A1:A15000]"

Const cstrTblB  As String = "[Foglio1$B1:C250]"

Const cstrSql   As String = "UPDATE " & cstrTblA & " A" & _

                            " INNER JOIN " & cstrTblB & " B" & _

                            " ON B.F1=A.F1" & _

                            " SET A.F1=B.F2;"

Const adStateOpen         As Long = 1

Const adCmdText           As Long = 1

Const adExecuteNoRecords  As Long = &H80

Dim cnn     As Object 'ADODB.Connection

Dim strCnn  As String

Dim lngRecs As Long

      strCnn = Replace(cstrCnn, "<DATASOURCE>", ThisWorkbook.FullName)

      Set cnn = CreateObject(Class:="ADODB.Connection")

      cnn.Open strCnn

      If cnn.State = adStateOpen Then

        cnn.Execute cstrSql, lngRecs, adCmdText Or adExecuteNoRecords

        MsgBox "RecordsAffected=" & CStr(lngRecs)

      Else

        MsgBox "Connessione chiusa."

      End If

ExtP: On Error Resume Next

      cnn.Close

      Set cnn = Nothing

      On Error GoTo 0

      Exit Sub

ErrH: MsgBox Err.Description, vbCritical, "ERR#" & Err.Number

      Resume ExtP

End Sub

Answer 2

Ciao Francis, 

Io ho interpretato la tua domanda in modo leggermente diverso di Mauro per cui prova qualcosa del genere:

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

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

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim sh As Worksheet

    Dim rngA As Range, rngB As Range, RngC As Range

    Dim arrA As Variant, arrB As Variant, arrC As Variant

    Dim aRow As Long, bRow As Long

    Dim i As Long, j As Long

    Set WB = ThisWorkbook

    Set sh = WB.Sheets("Foglio1")                                      '<<===== Modifica

    With sh

        aRow = LastRow(sh, .Columns("A:A"))

        bRow = LastRow(sh, .Columns("B:B"))   

        Set rngA = .Range("A2:A" & aRow)

        Set rngB = .Range("B2:B" & bRow)

        Set RngC = rngB.Offset(, 1)

    End With

    arrA = rngA.Value

    arrB = rngB.Value

    arrC = RngC.Value

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

        For j = LBound(arrA) To UBound(arrA)

            If arrA(j, 1) = arrB(i, 1) Then

                arrA(j, 1) = arrC(i, 1)

            End If

        Next j

    Next i

    rngA.Value = arrA

End Sub

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

Public 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 a Excel.
• Alt-F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester | Esegui

[Edit]

Ho modificato l'intervallo per definire bRow da .Columns("A:A") a .Columns("B:B")

===

Regards,

Norman

Answer 3

Io devo creare una macro che vada a cercare ogni valore della COLONNA B nella COLONNA A e che sostituisca ad ognuno dei valori trovati il Valore Corretto della COLONNA C.

<cut>

Se (se) ho capito:

Public Sub m()

    Dim sh As Worksheet

    Dim rngA As Range

    Dim rngB As Range

    Dim rng As Range

    Dim c As Range

    Set sh = ThisWorkbook.Worksheets("Foglio1")

    Set rngA = sh.Range("A1:A10")

    Set rngB = sh.Range("B1:B4")

    For Each c In rngB

        Set rng = Range(rngA.Address).Find( _

                What:=c.Value, _

                LookAt:=xlPart, _

                LookIn:=xlValues)

        If Not rng Is Nothing Then

            rng.Value = c.Offset(0, 1).Value

        End If

        Set rng = Nothing

    Next

    Set rngA = Nothing

    Set rngB = Nothing

    Set sh = Nothing

End Sub

Non ho capito se le sostituzioni in colonna A sono univoche. Se non lo sono:

Public Sub m()

    Dim sh As Worksheet

    Dim rngA As Range

    Dim rngB As Range

    Dim c1 As Range

    Dim c2 As Range

    Set sh = ThisWorkbook.Worksheets("Foglio1")

    Set rngA = sh.Range("A1:A10")

    Set rngB = sh.Range("B1:B4")

    For Each c1 In rngB

        For Each c2 In rngA

            If c1.Value = c2.Value Then

                c2.Value = c1.Offset(0, 1).Value

            End If

        Next

    Next

    Set rngA = Nothing

    Set rngB = Nothing

    Set sh = Nothing

End Sub

Sostituisci le parti in grassetto con i tuoi riferimenti.