Accodare su colonna al risultato di una macro quello di un' altra

Question

Ciao a tutti,

ho preso dalla rete una macro (presente nel modulo1) che scritta una parola sulla cella A2 mi restituisce sulla colonna B, a partire da B2, tutti i suoi sinonimi.

Fino a qui nessun problema; ma il mio obiettivo e' quello di poter accodare sulla medesima colonna (B), a partire dall' ultima cella disponibile anche le informazioni estratte dalla macro presente sul secondo modulo.

Ho fatto delle prove con scarso risultato e pertanto al fine di non ingarbugliare il codice mi rimetto al vostro aiuto.

Se inoltre non diventa complicato, chiedo se si possano distinguere le due tipologie di informazioni (sinonimi e contrari) facendo scrivere il numero 1 per i primi e lo zero per i secondi sulla colonna adiacente C.

Ciao A.

https://skydrive.live.com/redir.aspx?cid=dd405b0d5a6097c5&resid=DD405B0D5A6097C5!127&parid=root

file: Sin_Contr

Answer 1

Ho provato ad apportare la modifica:

Range("B2").Select....

....... segue codice

call Contrari

e va bene, grazie.

A.

 

 

 

Questa fa tutto in una volta:

Public Sub m()

On Error GoTo RigaErrore

    Dim objWord As Object

    Dim objContrari As Object

    Dim objDoc As Object

    Dim vContrari As Variant

    Dim v As Variant

    Dim lng As Long

    Dim col As Collection

    Dim lCont As Long

    Dim lRiga As Long

    Dim vSinonimi As Variant

    Dim lSinonimi As Long

    Set objWord = CreateObject("Word.Application")

    Set objDoc = objWord.Documents.Add()

    Set col = New Collection

    Set objWord = CreateObject("Word.Application")

    With ActiveSheet

        Set objContrari = objWord.SynonymInfo(.Range("A2").Value)

        lRiga = .Range("B" & .Rows.Count).End(xlUp).Row

        .Range("B2:C" & lRiga).Value = ""

        lCont = 2

        objWord.Visible = False

        vContrari = objContrari.AntonymList

        On Error Resume Next

        lSinonimi = objWord.SynonymInfo(.Range("A2").Value, 1040).MeaningCount

        If lSinonimi > 0 Then

            vSinonimi = objWord.SynonymInfo(.Range("A2").Value, 1040).MeaningList

        End If

        If lSinonimi > 0 Then

            For lng = 0 To lSinonimi

                col.Add CStr(vSinonimi(lng)), CStr(vSinonimi(lng))

            Next

        End If

    End With

    For lng = 0 To UBound(vContrari) - 1

        col.Add CStr(vContrari(lng)), CStr(vContrari(lng))

    Next

    For Each v In col

        With ActiveSheet

            .Cells(lCont, 2).Value = v

            If lCont < lSinonimi + 2 Then

                .Cells(lCont, 3).Value = 1

            Else

                .Cells(lCont, 3).Value = 0

            End If

            lCont = lCont + 1

        End With

    Next

    On Error GoTo 0

RigaChiusura:

    objWord.Quit

    objDoc.Close

    Set col = Nothing

    Set objContrari = Nothing

    Set objDoc = Nothing

    Set objWord = Nothing

    Exit Sub

RigaErrore:

    MsgBox Err.Number & vbNewLine & Err.Description

    Resume RigaChiusura

End Sub

Answer 2

la macro Sinonimi seleziona la cella A2 automaticamente, mentre Contrari richiede che venga selezionata dall'utente, se la vuoi lanciare da Sinonimi, basta fare questa modifica

    Range("B2").Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.ClearContents

    Range("A2").Select

 ............... segue codice

call Contrari

io però preferirei creare una colonna apposita per i contrari partendo da C2 ed utilizzare una macro come questa:

Sub Contrari()

Dim i As Long, uRiga As Long

Dim sWord As String

Dim arr

    Range("C2").Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.ClearContents

    Range("A2").Select

    uRiga = Range("C2").Row - 1

    sWord = Range("A2").Value

    If GetMeanings(sWord, arr) Then

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

        Cells(uRiga + i, 3).Value = arr(i)

    Next

    End If

Set mObjWord = Nothing

End Sub

Answer 3

Ciao patel45,

ho provato la  sub modificata e mi sembra che vada bene solo se la lancio singolarmente;

invece se faccio una call  all' interno della sub sinonimi  vengono fuori risultati inesatti.

A.

Questa sera riscrivo le macro, le unisco, le semplifico e le posto. Pazienza un attimo, grazie.

Answer 4

Ciao patel45,

ho provato la  sub modificata e mi sembra che vada bene solo se la lancio singolarmente;

invece se faccio una call  all' interno della sub sinonimi  vengono fuori risultati inesatti.

A.

Answer 5

prova questa

Sub Contrari()

Dim i As Long, uRiga As Long

Dim c As Range

Dim sWord As String

Dim arr

uRiga = Range("B1").End(xlDown).Row

For Each c In Selection

    sWord = c

    If GetMeanings(sWord, arr) Then

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

        Cells(uRiga + i, 2).Value = arr(i)

    Next

    End If

Next c

Set mObjWord = Nothing

End Sub