[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『データ抽出』（パイン）
問題管理表を作成し、Sheet2にデータの抽出を行いたいです。
Sheet1 ・・・一覧になっています。
新たなものはNo8、9・・・と追加する予定です。
NoがA4から始まっています。
No 応対方法 社名 区分 発生日 修正箇所 問題内容 対応方法 担当者 対応日 状態
1 電話 B社 不具合 2012/4/10 1 〇〇 ×× 鈴木 2012/4/1 完了
2 電話 D社 QA対応 2012/4/6 3 〇〇 ×× 佐藤 2012/4/8 完了
3 メール F社 要望 2012/5/1 2 〇〇 ×× 佐藤 2012/5/4 未完
4 メール C社 要望 2012/4/27 2 〇〇 ×× 高橋 保留
5 現地 C社 不具合 2012/5/1 8 〇〇 ×× 鈴木 2012/5/2 完了
6 電話 A社 その他 2012/5/9 6 ○〇 ×× 伊藤 保留
7 現地 B社 不具合 2012/5/10 4 〇〇 ×× 田中 2012/5/12 未完
Sheet2 ・・・A3が社名から始まっています。
社名 対応回数
Sheet1から発生日を参照
A社 1 Sheet1から状態を参照
Sheet1から修正箇所
Sheet1から発生日を参照 Sheet1から発生日を参照
B社 2 Sheet1から状態を参照 Sheet1から状態を参照
Sheet1から修正箇所 Sheet1から修正箇所
C社 ・・・・
このように参照したいです。
何かいい方法を教えていただけないでしょうか？
VBAの経験は殆どありません。
よろしくお願いします。
>VBAの経験は殆どありません
ということなので、なるべく標準的なコードだけで書いてみたけど、かえってゴチャついたかなぁ。 Dictionryを使えばもっとコンパクトになったような気がする。 さらに System.Collections.SortedList を使えば並び替えも省略できたけど。
まぁ、たたき台として。おそらくSheet2のA列、B列はセル結合をするんだろうけど、とりあえずは結合なしで。
なお、SHeet1のタイトル行の位置、Sheet2の開始行の位置を、先頭のConstで規定しているので間違っていれば修正してね。
Sub Sample()
Const sRow1 As Long = 4 'Sheet1のタイトル行
Const sRow2 As Long = 3 'Sheet2の転記開始行
Dim mRow1 As Long
Dim dLine1 As Long
Dim x As Long
Dim z As Long
Dim wkc As Long
Dim c As Range
Dim dV As Variant
Dim i As Long
Dim v() As Variant
Dim cpny As String
Dim cnt As Long
With Sheets("Sheet1")
'前準備
wkc = .Cells(sRow1, .Columns.Count).End(xlToLeft).Column + 2 'Sheet1の使用領域の左に作業域
mRow1 = .Range("A" & .Rows.Count).End(xlUp).Row 'Sheet1のリスト最終行番号
dLine1 = mRow1 - sRow1
'登場する会社を重複を排除して作業列に抽出
.Range("C" & sRow1).Resize(dLine1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, wkc), Unique:=True
'抽出した会社を昇順に並び替え
.Columns(wkc).Sort Order1:=xlAscending, Header:=xlYes, Key1:=.Columns(wkc)
dV = .Cells(1, wkc).CurrentRegion.Value '会社リストの配列取り込み
ReDim Preserve dV(1 To UBound(dV, 1), 1 To 3) '配列に会社別件数列追加
.Cells(1, wkc).CurrentRegion.Clear '作業列クリア
For i = 2 To UBound(dV, 1)
dV(i, 2) = WorksheetFunction.CountIf(.Range("C" & sRow1 + 1).Resize(dLine1), dV(i, 1)) '会社別の件数をセット
Next
x = WorksheetFunction.Max(WorksheetFunction.Index(dV, 0, 2)) '会社別の件数の最大値
ReDim v(1 To (UBound(dV, 1) - 1) * 3, 1 To 2 + x) 'Sheet2転記用配列生成
'データ処理開始
For Each c In .Range("C" & sRow1 + 1).Resize(dLine1)
cpny = c.Value
x = WorksheetFunction.Match(cpny, WorksheetFunction.Index(dV, 0, 1), 0)
dV(x, 3) = dV(x, 3) + 1
z = dV(x, 3)
cnt = dV(x, 2)
x = x - 2
v(x * 3 + 1, 1) = cpny
v(x * 3 + 1, 2) = cnt
v(x * 3 + 1, z + 2) = c.Offset(, 2).Text '発生日
v(x * 3 + 2, z + 2) = c.Offset(, 8).Value '状態
v(x * 3 + 3, z + 2) = c.Offset(, 3).Value '修正箇所
Next
End With
With Sheets("Sheet2")
.Rows(sRow2 & ":" & .Rows.Count).Clear
.Range("A" & sRow2).Resize(UBound(v, 1), UBound(v, 2)).Value = v
.Select
End With
MsgBox "転記完了"
End Sub
(ぶらっと)
本当にありがとうございました。
（パイン）
追加したところはわずかだけど、まぎらわしくなるのでフルセットを。
Sub Sample2()
Const sRow1 As Long = 4 'Sheet1のタイトル行
Const sRow2 As Long = 3 'Sheet2の転記開始行
Dim mRow1 As Long
Dim dLine1 As Long
Dim x As Long
Dim z As Long
Dim wkc As Long
Dim c As Range
Dim dV As Variant
Dim i As Long
Dim v() As Variant
Dim cpny As String
Dim cnt As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")
'前準備
wkc = .Cells(sRow1, .Columns.Count).End(xlToLeft).Column + 2 'Sheet1の使用領域の左に作業域
mRow1 = .Range("A" & .Rows.Count).End(xlUp).Row 'Sheet1のリスト最終行番号
dLine1 = mRow1 - sRow1
'登場する会社を重複を排除して作業列に抽出
.Range("C" & sRow1).Resize(dLine1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, wkc), Unique:=True
'抽出した会社を昇順に並び替え
.Columns(wkc).Sort Order1:=xlAscending, Header:=xlYes, Key1:=.Columns(wkc)
dV = .Cells(1, wkc).CurrentRegion.Value '会社リストの配列取り込み
ReDim Preserve dV(1 To UBound(dV, 1), 1 To 3) '配列に会社別件数列追加
.Cells(1, wkc).CurrentRegion.Clear '作業列クリア
For i = 2 To UBound(dV, 1)
dV(i, 2) = WorksheetFunction.CountIf(.Range("C" & sRow1 + 1).Resize(dLine1), dV(i, 1)) '会社別の件数をセット
Next
x = WorksheetFunction.Max(WorksheetFunction.Index(dV, 0, 2)) '会社別の件数の最大値
ReDim v(1 To (UBound(dV, 1) - 1) * 3, 1 To 2 + x) 'Sheet2転記用配列生成
'データ処理開始
For Each c In .Range("C" & sRow1 + 1).Resize(dLine1)
cpny = c.Value
x = WorksheetFunction.Match(cpny, WorksheetFunction.Index(dV, 0, 1), 0)
dV(x, 3) = dV(x, 3) + 1
z = dV(x, 3)
cnt = dV(x, 2)
x = x - 2
v(x * 3 + 1, 1) = cpny
v(x * 3 + 1, 2) = cnt
v(x * 3 + 1, z + 2) = c.Offset(, 2).Text '発生日
v(x * 3 + 2, z + 2) = c.Offset(, 8).Value '状態
v(x * 3 + 3, z + 2) = c.Offset(, 3).Value '修正箇所
Next
End With
With Sheets("Sheet2")
.Rows(sRow2 & ":" & .Rows.Count).Clear
.Range("A" & sRow2).Resize(UBound(v, 1), UBound(v, 2)).Value = v
For x = 1 To UBound(dV, 1) '会社数だけループしてA列、B列をそれぞれ結合セルに
i = (x - 1) * 3 + sRow2
.Cells(i, 1).Resize(3).Merge
.Cells(i, 2).Resize(3).Merge
Next
.Select
End With
Application.ScreenUpdating = True
MsgBox "転記完了"
End Sub
(ぶらっと)
横位置、縦位置ともに中央揃えにしたいので、
HorizontalAlignment = xlCenter
VerticalAlignment = xlCenter
を挿入したいのですが可能ですか？
.Cells(i, 1).Resize(3).Merge .Cells(i, 2).Resize(3).Merge
この２行を
With .Cells(i, 1).Resize(3)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Merge
End With
With .Cells(i, 2).Resize(3)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Merge
End With
(ぶらっと)
残りは罫線を引くことがありますが、
しばらくは自分でやってみます。
また教えていただければ幸いです。
ありがとうございました。
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.