ここから本文です

関数を使っている作業です。VBAマクロを使うことは可能でしょうか。数日考えたので...

mik********さん

2018/8/613:34:08

関数を使っている作業です。VBAマクロを使うことは可能でしょうか。数日考えたのですが、とくに条件3の指定方法がわかりません。詳しい方、ご教示いただけたら幸いです。

【実現したいこと】
あらかじめ条件1~4を指定のセルに入力しておき、「リスト作成」ボタンをクリックすると、別シートに条件を満たすメンバーの氏名、拠点、部署のリストが出る


【条件】
条件1:1種類の言語を指定
条件2:1種類を指定 ※指定の列に●が無いこと
条件3:◎の入ったグループのどれかに所属すること。
※グループは実際37グループあり、◎が入るグル―プ数は毎回異なる(20グループになることもある)
条件4:「対象外」列に●が無いこと(条件固定)

補足※条件4は固定の条件なので、入力用のセルはありません

どれか,条件,Then Exit For,vCs As Variant,指定,End With,End If

閲覧数:
185
回答数:
2
お礼:
500枚

違反報告

ベストアンサーに選ばれた回答

30246kikuさん

2018/8/618:32:43

雰囲気、以下でどうなりますか

細かい検証はしていないので、おかしかったら捨てるなり・・・・

標準モジュールに以下を記述し Samp1 を実行してみます
処理対象はアクティブシートの A1 ~ の表
条件の記述は、その表の右、1列空けた次の列に 条件1 ・・・ 等の文字列
結果は、新規シートに

条件3 の記述は、◎ / ● の違いが分からないので、空欄でなかったら・・・
全部空欄でも・・・
条件1、条件2 の右側も空欄でも・・・

なお、
・A1 ~ の表の2行目には、重複する文字列がないこと
・条件1 は、D 列固定

この条件があれば、
・条件2 に、他条件の うさぎ 等指定もできる
・条件3 に、りんご 等指定できる

そんな雰囲気で記述してみたつもり・・・・

どうなりますか


Option Explicit

Private Const CP As String = "●"
Private Const CSP As String = vbTab

Public Sub Samp1()
   Dim dic As Object
   Dim rng As Range
   Dim vA As Variant, vCs As Variant, vC As Variant, v As Variant
   Dim i As Long, j As Long, k As Long, n As Long

   With ActiveSheet
      With .Range("A1").CurrentRegion
         j = .Columns.Count + 2
         vA = .Offset(1).Resize(.Rows.Count - 1).Value
      End With
      Set rng = .Columns(j)
   End With

   Set dic = CreateObject("Scripting.Dictionary")
   dic.CompareMode = vbTextCompare

   For j = 4 To UBound(vA, 2)
      dic(vA(1, j)) = j
   Next

   If (fncSamp1(rng, dic, vCs, k)) Then
      n = 1
      For i = n + 1 To UBound(vA)
         For Each vC In vCs
            For Each v In Split(vC(k + 1), CSP)
               If (vA(i, dic(v)) = vC(k + 2)) Then Exit For
            Next
            If ((Not IsEmpty(v)) Xor vC(k)) Then Exit For
         Next
         If (IsEmpty(vC)) Then
            n = n + 1
            For j = 1 To 3
               vA(n, j) = vA(i, j)
            Next
         End If
      Next

      If (n > 1) Then
         Application.ScreenUpdating = False
         With Worksheets.Add
            With .Range("A2").Resize(n, 3)
               .Value = vA
               .Rows(1).Orientation = xlVertical
            End With
         End With
         Application.ScreenUpdating = True
      End If
   End If

   Set dic = Nothing
End Sub


Private Function fncSamp1(ByVal rng As Range, dic As Object _
            , vCs As Variant, k As Long) As Boolean
   Dim r As Range
   Dim vK As Variant, v As Variant
   Dim sS As String
   Dim j As Long, n As Long, m As Long

   fncSamp1 = False
   With rng
      If (WorksheetFunction.CountA(.Cells) = 0) Then Exit Function
      vCs = Array()
      k = LBound(vCs)
      n = UBound(vCs)
      n = n + 1
      ReDim Preserve vCs(n)
      vCs(n) = Array(False, "対象外", CP)
      m = 0
      For Each r In .SpecialCells(xlCellTypeConstants)
         Select Case StrConv(r.Value, vbNarrow)
            Case "条件1"
               If (r.Offset(, 1).Value <> "") Then
                  n = n + 1
                  ReDim Preserve vCs(n)
                  vCs(n) = Array(True, dic.Keys()(0), r.Offset(, 1).Value)
               End If
               m = m Or 1
            Case "条件2"
               vK = r.Offset(, 1).Value
               If (dic.Exists(vK)) Then
                  n = n + 1
                  ReDim Preserve vCs(n)
                  vCs(n) = Array(False, vK, CP)
               End If
               m = m Or 2
            Case "条件3"
               sS = ""
               j = 1
               Do While (1)
                  With r.Offset(, j)
                     vK = .Value
                     If (vK = "") Then Exit Do
                     If (dic.Exists(vK)) Then
                        If (.Offset(1).Value <> "") Then
                           sS = sS & CSP & vK
                        End If
                     End If
                  End With
                  j = j + 1
               Loop
               sS = Mid(sS, Len(CSP) + 1)
               If (sS <> "") Then
                  n = n + 1
                  ReDim Preserve vCs(n)
                  vCs(n) = Array(True, sS, CP)
               End If
               m = m Or 4
         End Select
         If (m = 7) Then Exit For
      Next
   End With
   If (m = 7) Then fncSamp1 = True
End Function

  • 30246kikuさん

    2018/8/718:22:49

    動き的にはどうでしたか?
    動きの確認には、以下変更必要ないと思いますが・・・


    結果を3列ではなく、表全部の列なら、
    Samp1 の、中・下あたりの以下2行を

    >   For j = 1 To 3
    >   With .Range("A2").Resize(n, 3)

    ↓ 3 を UBound(vA, 2) に

       For j = 1 To UBound(vA, 2)
       With .Range("A2").Resize(n, UBound(vA, 2))



    条件3 の、◎ / ● の違いがわかったので
    fncSamp1 内、条件3 の以下部分

    >   If (.Offset(1).Value <> "") Then
    >      sS = sS & CSP & vK
    >   End If

    ↓ ● は必須、その他空白以外で、表内のそこに ● あれば

       Select Case .Offset(1).Value
          Case CP
             n = n + 1
             ReDim Preserve vCs(n)
             vCs(n) = Array(True, vK, CP)
          Case Is <> ""
             sS = sS & CSP & vK
       End Select

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この回答は投票によってベストアンサーに選ばれました!

ベストアンサー以外の回答

1〜1件/1件中

プロフィール画像

カテゴリマスター

aka********さん

2018/8/615:59:35

フィルターの詳細設定を 使えば 添付の結果が 得られます。
私のデーターは 1行目が こうもにしています。

コードは
Sheet2.Select
Application.CutCopyMode = False
Sheets("Sheet1").Columns("A:N").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("D1:N3"), CopyToRange:=Range("A11:N30"), Unique:= _
False

です。

D3:G3まで =D2を オートフィル N3も =N2 としています。

リスト範囲が Sheets("Sheet1").Columns("A:N")
条件範囲が CriteriaRange:=Range("D1:N3")
D1:D3 及び N1:N3が ●で ないもの
E1:M3が ●か何もないか

出力範囲が CopyToRange:=Range("A11:N30")

となっています。


これで いかがでしょうか

ただ一つ メンバーJは どこにも属していないので 表示しています。
属さないといのもおかしいので 入力ミスとしています。

これでは だめでしょうか?

フィルターの詳細設定を 使えば 添付の結果が 得られます。
私のデーターは 1行目が こうもにしています。...

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる