エクセルマクロでのコピー貼り付けについて

質問

マクロ初心者です。手作業に限界を感じマクロを勉強しましたが力不足です。
質問ではなく申し訳ございませんがよろしくお願いします。
コピーして貼り付けるだけのことなのですが、
以下が元のデータです。

認識コード 名称 日付
00000229 A 2012/2/21
00000229 A 2010/10/5
00000470 B 2012/3/30
00000470 B 2011/3/31
00000496 C 2011/7/5
00000496 C 2010/8/17
00000496 C 空白

変更後の形です。

認識コード 名称 日付
00000229 A 2012/2/21 2010/10/5
00000470 B 2012/3/30 2011/3/31
00000496 C 2011/7/5 2010/8/17　　　空白

元データにある認識コードが同じ項目の日付を横に並べていきたいですのですが
繰り返しを含め空白欄のコピーもうまくできません。
厚かましいこと極まりないですが、ご指導していただければと思います。

回答No.3

tom04 · ベストアンサー

No.2です！
日付が表示されない！というコトですが・・・

おそらくSheet1のA列が文字列になっているのでは？
前回のコードはSheet1のA列は数値で表示形式が8桁となっている前提のコードでしたので
Sheet2のA列も数値を8桁表示としていました。
そうなると当然Sheet2のA・B列と一致するものはSheet1にはないので
日付部分は全く表示されないと思います。

もう一度コードを載せてみます。（ほとんど前回同様です）
今回はSheet1のA列が文字列だとしてのコードです。

Sub test() 'この行から
Dim i, k As Long
Dim myArray As Variant
Dim ws As Worksheet
Set ws = Worksheets("Sheet2") '←「Sheet2」は実際のSheet名に！
Application.ScreenUpdating = False
i = ws.Cells(Rows.Count, 1).End(xlUp).Row
If i > 1 Then
ws.Rows(2 & ":" & i).ClearContents
End If
ws.Columns(1).NumberFormatLocal = "@" 'この行を追加
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = _
Cells(i, 1) & "_" & Cells(i, 2)
Next i
For i = ws.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(ws.Columns(1), ws.Cells(i, 1)) > 1 Then
ws.Cells(i, 1).Delete (xlUp)
End If
Next i
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
myArray = Split(ws.Cells(i, 1), "_")
For k = 0 To 1
ws.Cells(i, k + 1) = myArray(k)
Next k
Next i
'前回のここの行を削除
For k = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = ws.Cells(k, 1) And Cells(i, 2) = ws.Cells(k, 2) Then
If Cells(i, 3) <> "" Then
With ws.Cells(k, Columns.Count).End(xlToLeft).Offset(, 1)
.Value = Cells(i, 3)
.NumberFormatLocal = "yyyy/m/d"
End With
Else
ws.Cells(k, Columns.Count).End(xlToLeft).Offset(, 1) = " "
End If
End If
Next i
Next k
Application.ScreenUpdating = True
End Sub 'この行まで

※　今回は上手く動けば良いのですが・・・m（_ _）m

お礼

tom04さん　ご指摘の通りでした。
完璧すぎてなんとお礼を言ってらよいか困っております。

仕事で必ず出てくるこの認識コードにはいつも振り回されています。
関数（Vlook等）でも手間をかけないとエラーばかり出ます。もう少し
変数の勉強するよう心がけます。

ありがとうございました。

回答No.2

tom04

こんばんは！
一例です。

Sheet1のデータをSheet2に表示するようにしてみました。

画面左下の元データがあるSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, k As Long
Dim myArray As Variant
Dim ws As Worksheet
Set ws = Worksheets("Sheet2") '←「Sheet2」は実際のSheet名に！
Application.ScreenUpdating = False
i = ws.Cells(Rows.Count, 1).End(xlUp).Row
If i > 1 Then
ws.Rows(2 & ":" & i).ClearContents
End If
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = _
Cells(i, 1) & "_" & Cells(i, 2)
Next i
For i = ws.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(ws.Columns(1), ws.Cells(i, 1)) > 1 Then
ws.Cells(i, 1).Delete (xlUp)
End If
Next i
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
myArray = Split(ws.Cells(i, 1), "_")
For k = 0 To 1
ws.Cells(i, k + 1) = myArray(k)
Next k
Next i
ws.Columns(1).NumberFormatLocal = "00000000"
For k = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = ws.Cells(k, 1) And Cells(i, 2) = ws.Cells(k, 2) Then
If Cells(i, 3) <> "" Then
With ws.Cells(k, Columns.Count).End(xlToLeft).Offset(, 1)
.Value = Cells(i, 3)
.NumberFormatLocal = "yyyy/m/d"
End With
Else
ws.Cells(k, Columns.Count).End(xlToLeft).Offset(, 1) = " "
End If
End If
Next i
Next k
Application.ScreenUpdating = True
End Sub 'この行まで

※　For～Next　を多用していますので、データ量が多い場合は少し時間がかかると思います。

参考になりますかね？m（_ _）m

お礼

捕捉欄に書き込んだ内容が元データの形です。これでもうまく表示できません。

(1)8ケタの数字が認識コード
(2)大文字アルファベットが名称
(3)日付
と3列にデータが入っています
作成していただいたマクロを実行したところ
日付がなぜかありませんでした。わかる範囲でマクロの内容を確認して
変更してみます。こんなに親切に指導していただけてとても
感謝しております。
tom04さん　ありがとうございました。

補足

認識コード/ 名称 /日付
00000001　/ A /2012/1/6
00000001/ A /2012/6/7
00000001/ A /2012/6/7
00000004/ B /2012/3/23
00000004/ B /2012/6/16
00000005/ C /2012/4/19
00000005/ C /2012/5/28

回答No.1

chie65536（@chie65535）

認識コード名称がA列、日付がB列で、１行目から入っているとする。

１．認識コード名称を昇順、日付を降順でソートする（と言うか、既にソートされていると思う）

２．C１セルに「1」と入力する。

３．C2セルに「=IF(A2=A1,0,1)」と入力する。

４．C２セルを下方向に表の終りまでコピーする。

表は

　　A　　　　　　　B　　　　　　　C
1　00000229A　2012/2/21　1
2　00000229A　2010/10/5　0
3　00000470B　2012/3/30　1
4　00000470B　2011/3/31　0
5　00000496C　2011/7/5　　1
6　00000496C　2010/8/17　0
7　00000496C　空白　　　　　0

となる筈。

５．D１セルに「=IF($C1=0,"",IF(ISBLANK(OFFSET($B1,COLUMN()-4,0)),"",IF($A1=OFFSET($A1,COLUMN()-4,0),OFFSET($B1,COLUMN()-4,0),"")))」と入力して書式を日付にする。

６．D1セルを右方向に必要なだけE1～にコピーする。日付を横に１０個並べたいなら、E1～M1にコピー。

７．E1～M1を範囲指定して、下方向に表の終りまでコピーする。

表が

　　A　　　　　　　B　　　　　　　C　D　　　　　　　E
1　00000229A　2012/2/21　1　2012/2/21　2010/10/5
2　00000229A　2010/10/5　0
3　00000470B　2012/3/30　1　2012/3/30　2011/3/31
4　00000470B　2011/3/31　0
5　00000496C　2011/7/5　　1　2011/7/5　2010/8/17
6　00000496C　2010/8/17　0
7　00000496C　空白　　　　　0

となる筈。

８．D～M列を範囲選択してCtrl+Cで「コピー」する。

９．そのまま「編集」「形式を指定して貼り付け」「値のみ」で、貼り付けする。見た目には変化しない。

10．オートフィルタで「C列の値が0の物だけ」を表示する。

表が

　　A　　　　　　　B　　　　　　　C　D　　　　　　　E
1　0000022▽　2012/2/▽　▽　2012/2/▽　2010/10▽
2　00000229A　2010/10/5　0
4　00000470B　2011/3/31　0
6　00000496C　2010/8/17　0
7　00000496C　空白　　　　　0

となる筈。１行目の「▽」は、オートフィルタのマーク。

11．表の２行目から最後までを範囲選択して「行削除」する。１行目は消さない事。

12．オートフィルタを解除する。

表が

　　A　　　　　　　B　　　　　　　C　　　　D　　　　　　　E
1　00000229A　2012/2/21　1　　　　2012/2/21　2010/10/5
2　00000470B　2012/3/30　#REF!　2012/3/30　2011/3/31
3　00000496C　2011/7/5　　#REF!　2011/7/5　2010/8/17

となる筈。

13．B列、C列を「列削除」する。

表が

　　A　　　　　　　B　　　　　　　C
1　00000229A　2012/2/21　2010/10/5
2　00000470B　2012/3/30　2011/3/31
3　00000496C　2011/7/5　　2010/8/17

となって完成。

お礼

不慣れなもので御礼を捕捉に書き込んでいました。
　大変失礼しました。
　改めてですいません。

　ありがとうございました。　

　参考にさせていただきます。

補足

chie65535さんへ

ありがとうございました。
とても参考になりました。
教えていただいた方法を元にもう少し頑張ってマクロにできればと思います。

元データの記載方法が悪く一部訂正させて頂きます。

A列　　　　　 B列　　　　 C列
認識コード　　名称　　　　日付
00000496　　　C　　　　　2011/7/5