excelデータの切り貼りマクロ

質問

excelマクロの初心者です。
データの切り貼りをするマクロについて教えてください。

以下のような担当者と会社名の入った縦に大きなデータを

担当 社名
佐藤 A社
佐藤 B社
佐藤 C社
田中 D社
田中 E社
田中 F社
鈴木 G社
鈴木 H社
鈴木 I社
高橋 J社
高橋 K社
高橋 L社

最終的に

佐藤 田中 鈴木 高橋
A社 D社 G社 J社
B社 E社 H社 K社
C社 F社 I社 L社

このように一番上に担当者、下に該当する社名を羅列されるように切り貼りをしたいと思っています。
ファイルがいくつもあり、また行数はファイルごとに異なり一定ではありません。
マクロでどのように書いたらよいかご教授頂けないでしょうか。

よろしくお願いいたします<(_ _)>

回答No.2

keithin · ベストアンサー

どのようにしても出来ますが、まぁあんまり一行一行舐めまわして作成するようなよりは、もうちょっと高速なやり方を考えてみます。

状況の設定：
１行目にタイトル行、２行目からデータ、Ａ，Ｂ列にデータ。
沢山やらなきゃならないのは構いませんが、具体的に一体「どこに」どんな風に結果を並べたいのかご相談で考えられてないので、てきとーにシートを作成して並べ替えることにする

データのあるシートを開いてマクロを実行する。

sub macro1()
　dim w0 as worksheet
　dim h as range

’準備
　set w0 = activesheet
　worksheets.add after:=w0

’担当一覧の抽出
　w0.range("A:A").advancedfilter action:=xlfiltercopy, copytorange:=range("A1"), unique:=true
　range("A2:A" & range("A65536").end(xlup).row).copy
　range("A1").pastespecial transpose:=true
　range("A2:A" & range("A65536").end(xlup).row).clearcontents

’担当ごとの抽出
　for each h in range(range("A1"), range("IV1").end(xltoleft))
　　w0.range("A:A").autofilter field:=1, criteria1:=h.value
　　w0.range("B2:B" & w0.range("B65536").end(xlup).row).copy destination:=h.offset(1)
　next
　w0.autofiltermode = false
end sub

お礼

ありがとうございます！
いっっっしゅんでできましたTT
感動しました。。。

回答No.1

tom04

こんばんは！
一例です。

元データはSheet1のA・B列にあり、1行目は項目行でデータは2行目以降にあるとします。
Sheet2に表示するようにしてみました。

標準モジュールです。

Sub Sample1()
Dim j As Long, lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS.Cells.Clear
With Worksheets("Sheet1")
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("D1"), unique:=True
lastRow = .Cells(Rows.Count, "D").End(xlUp).Row
Range(.Cells(2, "D"), .Cells(lastRow, "D")).Copy
wS.Range("A1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
Application.CutCopyMode = False
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To wS.Cells(1, Columns.Count).End(xlToLeft).Column
.Range("A1").AutoFilter field:=1, Criteria1:=wS.Cells(1, j)
Range(.Cells(2, "B"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy wS.Cells(2, j)
Next j
.AutoFilterMode = False
.Range("D:D").Clear
End With
Application.ScreenUpdating = True
wS.Activate
End Sub

※　Sheet1のD列を作業用の列として使用していますので、D列は使っていない状態にしておいてください。

こんな感じではどうでしょうか？m(_ _)m

お礼

ありがとうございます!!!
あっという間にできてしまってびっくりしました。
本当に助かりました!!!