人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

1399549004
●拡大する


●質問者: dejavu888i
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● きゃづみぃ
●500ポイント ベストアンサー


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の一列に出力する行数です。

きゃづみぃさんのコメント
抽出のSubを実行すればいいです。 ほかは、その中で使用しているモジュールです。

dejavu888iさんのコメント
シート1 = "Sheet1" シート3 = "Sheet2" シート4 = "Sheet3" "Sheet2"の部分は変更できますが"シート3"の変更方法がわからないのですがどうしたらできますか?素人すぎてすんません。 その変更ができていない為だと思うのですが、シート3の部分が上手く抽出されません。

きゃづみぃさんのコメント
シート3は 内部で使用するものなので、変更しなくてもよいです。 "Sheet1"、"Sheet2"、"Sheet3"を 変更してください。

きゃづみぃさんのコメント
シート1 = "シート1" シート3 = "シート3" シート4 = "シート4" に したほうが わかりやすいのかな?

dejavu888iさんのコメント
すんません。仕事が忙しくなり中断してしまいました。 しかし、再度やってみても上手く動きません。(/_;)

きゃづみぃさんのコメント
データ開始位置 = 1 'データの開始位置はA1からです。 これを データ開始位置 = 3 'データの開始位置はA3からです。 にしたほうがいいかな?

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

きゃづみぃさんのコメント
シート名は、存在するシートじゃないとダメです。 画像のように なっている状態で、それぞれ作成されることを確認しました。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ