重複を削除し、連結したものを上から削除します。

Question

次のマクロをコーディングしていますが、値を直接ウィンドウに保存すると機能しますが、 "、"で区切られた値を1つのセルに入れる方法はわかりません。基本的に私は列で「アクティブ」を探し、見つかった場合は左側に4つのセルを移動し、そこから情報を取得します。 助けてください。

Dim Active() As Variant 
Dim i 
ReDim Active(Range("G9:G24").Cells.Count) 
For Each Zelle In Range("G9:G24") 
If InStr(1, Zelle, "Active") <> 0 Then 
Active(i) = Zelle.Offset(0, -4) 
End If 
i = i + 1 
Next Zelle 

For i = LBound(Active) To UBound(Active) 
If Trim(Active(i)) <> "" Then 
    Debug.Print Active(i) 
    End If 
    Next i 
    End Sub 

Answer 1

あなたが大幅にのみ、列Cにはない、空白のセルに対応する希望範囲のセルをループして、コードを短くすることができ

Dim Zelle As Range 
    Dim resultStrng As String 

    For Each Zelle In Range("G9:G24").Offset(,-4).SpecialCells(xlCellTypeConstants) '<--| loop through not blank cell in range 4 columns to the left of G9:G24 
     If InStr(1, Zelle.Offset(, 4), "Active") <> 0 And Trim(Zelle) <> "" And Instr(resultStrng, Trim(Zelle)) =0 Then resultStrng = resultStrng & Trim(Zelle) & "," '<--| update your result string whenever current cell has a character and its 4 columns to the right offset cell meets the "Active" criteria 
    Next Zelle 
    If resultStrng <> "" Then resultStrng = Left(resultStrng, Len(resultStrng) - 1) '<-- remove the last comma from 'resultStrng' 

Answer 2

次のようにループを書き直すその後、次の

を追加します。そして、あなたがセルにsを割り当てることができます

For i = LBound(Active) To UBound(Active) 
    If Trim(Active(i)) <> "" Then 
     s = s & IIf(Len(s)>0, ",", "") & trim(Active(i)) 
     End If 
Next i 

。