[Risolto] trova e sostituisci valori

[b1313]

Ciao!
ho una colonna che contiene valori separati da virgola.
vorrei che nella colonna a fianco mi uscissero i valori sostituiti (come esempio colonna RISULTATO) seguendo una legenda creata nel Foglio2.
qualcuno mi può aiutare con una macro?
allego un esempio del file.
grazie

[Gaetanopr]

Bisogna definire l'area del secondo foglio "A2:B11" con il nome "TABELLA"

Codice: Seleziona tutto

Sub Main
Dim Riscontri()
Dim svc As Object
doc=thiscomponent
Sh1 =  Doc.Sheets(0)
Sh2 =  Doc.Sheets(1)
c = Sh1.createCursor
c.gotoEndOfUsedArea(false)
LastRow = c.RangeAddress.EndRow             
svc = createUnoService("com.sun.star.sheet.FunctionAccess")
Tabella = Sh2.getCellRangeByName("TABELLA")  

  For i = 1 to LastRow   
    x = 0 
    oCell1 = Sh1.getCellByPosition(0, i)
    Array1 = Split(oCell1.String,",")
    For n = Lbound(Array1) To Ubound(Array1)
        vlook = svc.callFunction("VLOOKUP",Array(Array1(n), Tabella, 2, False))
        If IsEmpty(vlook) = False Then
           Redim Preserve Riscontri(0 to x)
           Riscontri(x) = vlook 
           x = x + 1
        End If     
    Next n
    If x > 0 Then 
       Sh1.getCellByPosition(2, i).String = Join( Riscontri(), "," )
    Else 
       Sh1.getCellByPosition(2, i).String = ""
    End if   
  Next i          
   

End Sub

[b1313]

Ciao!
grazie per l'aiuto.
Ho provato la macro aggiungendo dei valori nel foglio TABELLA, non so se sbaglio io, ma salta i valori dopo il 10, come vedi nel file allegato.

grazie

Bisogna definire l'area del secondo foglio "A2:B11" con il nome "TABELLA"

Codice: Seleziona tutto

Sub Main
Dim Riscontri()
Dim svc As Object
doc=thiscomponent
Sh1 =  Doc.Sheets(0)
Sh2 =  Doc.Sheets(1)
c = Sh1.createCursor
c.gotoEndOfUsedArea(false)
LastRow = c.RangeAddress.EndRow             
svc = createUnoService("com.sun.star.sheet.FunctionAccess")
Tabella = Sh2.getCellRangeByName("TABELLA")  

  For i = 1 to LastRow   
    x = 0 
    oCell1 = Sh1.getCellByPosition(0, i)
    Array1 = Split(oCell1.String,",")
    For n = Lbound(Array1) To Ubound(Array1)
        vlook = svc.callFunction("VLOOKUP",Array(Array1(n), Tabella, 2, False))
        If IsEmpty(vlook) = False Then
           Redim Preserve Riscontri(0 to x)
           Riscontri(x) = vlook 
           x = x + 1
        End If     
    Next n
    If x > 0 Then 
       Sh1.getCellByPosition(2, i).String = Join( Riscontri(), "," )
    Else 
       Sh1.getCellByPosition(2, i).String = ""
    End if   
  Next i          
   

End Sub

[Gaetanopr]

Bisogna definire l'area del secondo foglio "A2:B11" con il nome "TABELLA"

L'area che avevo definito arriva alla cella B11 se allunghi la tabella devi pure modificare l'area di questa andando su Inserisci - Nomi - Definisci - selezioni TABELLA e modifichi il range

Altrimenti cambia la macro in questo modo, così non c'è bisogno di definire il nome "TABELLA"

Codice: Seleziona tutto

Sub Main
Dim Riscontri()
Dim svc As Object
doc=thiscomponent
Sh1 =  Doc.Sheets.getByName("Foglio1")
Sh2 =  Doc.Sheets.getByName("TABELLA")
c = Sh1.createCursor
c.gotoEndOfUsedArea(false)
LastRow = c.RangeAddress.EndRow

a = Sh2.createCursor
a.gotoEndOfUsedArea(false)
LastRow2 = a.RangeAddress.EndRow
               
svc = createUnoService("com.sun.star.sheet.FunctionAccess")
Tabella = Sh2.getCellRangeByName("A2:B" & LastRow2+1)  

  For i = 1 to LastRow   
    x = 0 
    oCell1 = Sh1.getCellByPosition(0, i)
    Array1 = Split(oCell1.String,",")
    For n = Lbound(Array1) To Ubound(Array1)
        vlook = svc.callFunction("VLOOKUP",Array(Array1(n), Tabella, 2, False))
        If IsEmpty(vlook) = False Then
           Redim Preserve Riscontri(0 to x)
           Riscontri(x) = vlook 
           x = x + 1
        End If     
    Next n
    If x > 0 Then 
       Sh1.getCellByPosition(1, i).String = Join( Riscontri(), "," )
    Else 
       Sh1.getCellByPosition(1, i).String = ""
    End if   
  Next i          
   

End Sub

[b1313]

perfetto grazie!

Editato: Eliminata citazione, perchè inutile (moderatore charlie)