| |
▼ぴ〜ちゃん さん：
おはようございます。
誤字とコード訂正です。
>当該フォームモジュールに
>'=========================================================
>Private Sub UserForm_Initialize()
> Dim func_str As String
> func_str = "=if(countif(sheet1!$a$1:a1,a1)>1,"""",a1)"
> Call set_combo_item(ComboBox1, func_str)
> func_str = "=if(sheet1!a1=""" & ComboBox1.Text & """,sheet1!b1,"""")"
> Call set_combo_item(ComboBox2, func_str)
>End Sub
>'=========================================================
>Private Sub ComboBox1_Change()
> Dim func_str As String
> func_str = "=if(sheet1!a1=""" & ComboBox1.Text & """,sheet1!b1,"""")"
> Call set_combo_item(ComboBox2, func_str)
>End Sub
>'=========================================================
>Private Sub CommandButton1_Click()
Dim func_str As String
Dim rng As Range
Dim f_row As Long
Dim w_row As Long
func_str = "=if(and(sheet1!a1=""" & ComboBox1.Text & """,sheet1!b1=""" & ComboBox2.Text & """),row(),"""")"
Set rng = get_func_rng(func_str)
f_row = rng.Row
w_row = ActiveCell.Row
With Worksheets("sheet1")
Range(Cells(w_row, 1), Cells(w_row, 4)).Value _
= .Range(.Cells(f_row, 1), .Cells(f_row, 4)).Value
End With
'一括で移行できるんだった
rng.Value = ""
>End Sub
>'=========================================================
>Function get_func_rng(func_str As String) As Range
>'input: func_str ﾃﾞｰﾀ抽出のための関数式
>'out : get_func_rng 条件に合ったセル範囲
> Dim rng As Range
> With ThisWorkbook.Worksheets("sheet1")
> Set rng = .Range("a1", .Range("a65536").End(xlUp))
> End With
> rng.Offset(0, 5).Formula = func_str
> rng.Offset(0, 5) = rng.Offset(0, 5).Value
> Set get_func_rng = rng.Offset(0, 5).SpecialCells(xlCellTypeConstants)
' ↑上３行でＦ列を使っています、変更するなら5を別の数字に
>End Function
>'=========================================================
>Sub set_combo_item(cmb As MSForms.ComboBox, func_str As String)
>'input: cmb ﾃﾞｰﾀをセットするコンボボックス
>'input: func_str ﾃﾞｰﾀ抽出のための関数式
> Dim rng As Range
> Dim rng2 As Range
> Set rng2 = get_func_rng(func_str)
> cmb.Clear
> For Each rng In rng2
> cmb.AddItem rng.Value
> Next
> cmb.ListIndex = 0
> rng2.Value = ""
> Set rng = Nothing
> Set rng2 = Nothing
>End Sub
>
>
>次にシート2のシートモジュールに
>'===========================================================
>Private Sub Worksheet_Activate()
> UserForm1.Show vbModeless
>End Sub
>'===========================================================
>Private Sub Worksheet_Deactivate()
Application.ScreenUpdating = False
> Unload UserForm1
Application.ScreenUpdating = True
>End Sub
>'===========================================================
>Private Sub Worksheet_SelectionChange(ByVal Target As Range)
> With UserForm1
> If .Visible = False Then .Show vbModeless
> End With
>End Sub
>
>尚、シート2では、コマンドボタンクリック時にどこのセルを選択しても
>選択されたセルと同じ行のＡ列からﾃﾞｰﾀが貼り付けられる仕様になっています。
|
|
ichinose
- 03/12/13(土) 9:52 -
