id:dejavu888i
ポイントあり500ptベストアンサーあり
コンピュータ

1399549004 エクセル2007を利用していますが、前回質問させて頂きマクロを使った方法を指導して頂きました。

ピックアップしたデーターをマクロを使って表を作成した中に表示したいと思い再度投稿させて頂きました。
また、ご指導のほど宜しくお願いいたします。詳しくは添付ファイルに記入しております。

回答の条件
  • 1人5回まで
  • 登録：
  • 終了：2014/05/15 20:40:05
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:taknt No.1

回答回数13539ベストアンサー獲得回数1198

ポイント500pt 


Sub 抽出()
    Dim r As Long
    Dim f As Long
    Dim 位置 As Long
    Dim メンバー名前() As String
    Dim メンバーソート用() As String
    Dim メンバー場所() As String
    Dim ソート用 As String
    Dim シート1 As String
    Dim シート3 As String
    Dim シート4 As String
    Dim 出力開始位置3 As Long
    Dim 出力開始位置4 As Long
    Dim 出力単位4 As Long
    
    シート1 = "Sheet1"
    シート3 = "Sheet2"
    シート4 = "Sheet3"
    データ開始位置 = 1            'データの開始位置はA1からです。
    出力開始位置3 = 1             'シート3の出力の開始位置はA1からです。
    出力開始位置4 = 1             'シート4の出力の開始位置はA1からです。
    出力単位4 = 20                'シート4の一列に出力する行数です。
    
    
    曜日 = "月火水木金土"
        
    Worksheets(シート3).Cells.Delete Shift:=xlUp
    Worksheets(シート4).Cells.Delete Shift:=xlUp
    
   'シート3の作成------------------------------------------------------
    
    For a = 1 To 6
        ReDim メンバー名前(0)
        ReDim メンバーソート用(0)
        ReDim メンバー場所(0)
    
        For r = データ開始位置 To Rows().Count
            If Worksheets(シート1).Cells(r, "A") = "" Then
                Exit For
            End If
            For f = 7 To Columns().Count
                If Worksheets(シート1).Cells(r, f) = "" Then
                    Exit For
                End If
            
                If Worksheets(シート1).Cells(r, f) = Mid(曜日, a, 1) Then
                    ReDim Preserve メンバー名前(UBound(メンバー名前) + 1)
                    ReDim Preserve メンバーソート用(UBound(メンバーソート用) + 1)
                    ReDim Preserve メンバー場所(UBound(メンバー場所) + 1)
                    メンバー名前(UBound(メンバー名前) - 1) = Worksheets(シート1).Cells(r, "A")
                    メンバーソート用(UBound(メンバーソート用) - 1) = Worksheets(シート1).Cells(r, "B")
                    メンバー場所(UBound(メンバー場所) - 1) = Worksheets(シート1).Cells(r, "C")
                    Exit For
                End If
            
            Next f
        Next r
        
        For r = 0 To UBound(メンバーソート用) - 2
            For f = r + 1 To UBound(メンバーソート用) - 1
                If メンバーソート用(r) > メンバーソート用(f) Then
                    ソート用 = メンバーソート用(r)
                    メンバーソート用(r) = メンバーソート用(f)
                    メンバーソート用(f) = ソート用
                
                    ソート用 = メンバー名前(r)
                    メンバー名前(r) = メンバー名前(f)
                    メンバー名前(f) = ソート用
                
                    ソート用 = メンバー場所(r)
                    メンバー場所(r) = メンバー場所(f)
                    メンバー場所(f) = ソート用
                End If
            Next f
        Next r
        
        Worksheets(シート3).Cells(出力開始位置3, (a - 1) * 2 + 1) = Mid(曜日, a, 1) & "曜日"
        
        For r = 0 To UBound(メンバーソート用) - 1
            Worksheets(シート3).Cells(出力開始位置3 + r + 1, (a - 1) * 2 + 1) = メンバー名前(r)
            Worksheets(シート3).Cells(出力開始位置3 + r + 1, (a - 1) * 2 + 2) = メンバー場所(r)
        Next r
        
        Call 罫線3(シート3, 出力開始位置3, (a - 1) * 2 + 1, UBound(メンバーソート用) + 出力開始位置3)
    Next a
    


   'シート4の作成------------------------------------------------------

    ReDim メンバー名前(0)
    ReDim メンバーソート用(0)
    ReDim メンバー場所(0)

    For r = データ開始位置 To Rows().Count
        If Worksheets(シート1).Cells(r, "A") = "" Then
            Exit For
        End If
        
        ReDim Preserve メンバー名前(UBound(メンバー名前) + 1)
        ReDim Preserve メンバーソート用(UBound(メンバーソート用) + 1)
        ReDim Preserve メンバー場所(UBound(メンバー場所) + 1)
        メンバー名前(UBound(メンバー名前) - 1) = Worksheets(シート1).Cells(r, "A")
        メンバーソート用(UBound(メンバーソート用) - 1) = Worksheets(シート1).Cells(r, "B")
        メンバー場所(UBound(メンバー場所) - 1) = Worksheets(シート1).Cells(r, "D")
    Next r
    
    For r = 0 To UBound(メンバーソート用) - 2
        For f = r + 1 To UBound(メンバーソート用) - 1
            If メンバーソート用(r) > メンバーソート用(f) Then
                ソート用 = メンバーソート用(r)
                メンバーソート用(r) = メンバーソート用(f)
                メンバーソート用(f) = ソート用
            
                ソート用 = メンバー名前(r)
                メンバー名前(r) = メンバー名前(f)
                メンバー名前(f) = ソート用
            
                ソート用 = メンバー場所(r)
                メンバー場所(r) = メンバー場所(f)
                メンバー場所(f) = ソート用
            End If
        Next f
    Next r
    
    a = 1
    f = 0
    For r = 0 To UBound(メンバーソート用) - 1
        Worksheets(シート4).Cells(出力開始位置4 + f, (a - 1) * 3 + 1) = r + 1
        Worksheets(シート4).Cells(出力開始位置4 + f, (a - 1) * 3 + 2) = メンバー名前(r)
        Worksheets(シート4).Cells(出力開始位置4 + f, (a - 1) * 3 + 3) = メンバー場所(r)
        f = f + 1
        If f > 出力単位4 - 1 Then
            Call 罫線4(シート4, 出力開始位置4, (a - 1) * 3 + 1, 出力単位4 + 出力開始位置4 - 1)
            a = a + 1
            f = 0
        End If
    Next r
    
    If f > 0 Then
        Call 罫線4(シート4, 出力開始位置4, (a - 1) * 3 + 1, 出力単位4 + 出力開始位置4 - 1)
    End If

End Sub


Sub 罫線3(s1 As String, a1 As Long, b1 As Long, c1 As Long)
    With Worksheets(s1).Range(Worksheets(s1).Cells(a1, b1), Worksheets(s1).Cells(c1, b1 + 1))
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeTop).ColorIndex = xlAutomatic
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlMedium
        .Borders(xlEdgeRight).ColorIndex = xlAutomatic
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideVertical).ColorIndex = xlAutomatic
        .Borders(xlInsideHorizontal).LineStyle = xlDash
        .Borders(xlInsideHorizontal).Weight = xlThin
        .Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
    End With

    '曜日の枠
    With Worksheets(s1).Range(Worksheets(s1).Cells(a1, b1), Worksheets(s1).Cells(a1, b1 + 1))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeTop).ColorIndex = xlAutomatic
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlMedium
        .Borders(xlEdgeRight).ColorIndex = xlAutomatic
    End With
    
End Sub



Sub 罫線4(s1 As String, a1 As Long, b1 As Long, c1 As Long)
    With Worksheets(s1).Range(Worksheets(s1).Cells(a1, b1), Worksheets(s1).Cells(c1, b1 + 2))
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeTop).ColorIndex = xlAutomatic
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlMedium
        .Borders(xlEdgeRight).ColorIndex = xlAutomatic
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlInsideVertical).Weight = xlThin
        .Borders(xlInsideVertical).ColorIndex = xlAutomatic
        .Borders(xlInsideHorizontal).LineStyle = xlDash
        .Borders(xlInsideHorizontal).Weight = xlThin
        .Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
    End With

End Sub


前回と同様、以下の箇所を変更して使用してください。

    シート1 = "Sheet1"
    シート3 = "Sheet2"
    シート4 = "Sheet3"
    データ開始位置 = 1            'データの開始位置はA1からです。
    出力開始位置3 = 1             'シート3の出力の開始位置はA1からです。
    出力開始位置4 = 1             'シート4の出力の開始位置はA1からです。
    出力単位4 = 65                'シート4の一列に出力する行数です。
他6件のコメントを見る
id:dejavu888i

シート名を変更すると上手く動作せずSheet1/2/3の初期値のままにしてデーターの開始位置を3にするとSheet2では曜日だけが月～土まで罫線に囲まれて表示されてデーターが抽出されませんでした。Sheet3は希望通りに表示されています。

2014/05/15 07:49:58
id:taknt

シート名は、存在するシートじゃないとダメです。

画像のように なっている状態で、それぞれ作成されることを確認しました。

2014/05/15 20:37:25

コメント（0件)

コメントはまだありません

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ