エクセル2010 マクロでデータ移動

質問

エクセル2010を使っています。

一人では解けない問題が出てきましたので、詳しいかた教えて頂けませんでしょうか？

画像の様なデータがあり、A列にデータがあります。

そのA列の　【日付】　の文字の下セルの文字を　B列にリンクのまま抜き出します。

抜き出し元のセルの下のセルから　【メモ】を含むセルの、1行上のセルまでをD列に上から順に抜き出します。

最後に　【メモ】を含むセルをE列に抜き出し、枠線を与えます。

ちなみに、画像の様に途中ランダムに文字が入りますが、抜き出したい部分は必ず　【日付】　と　【メモ】の間にあります。

ただ1点気になるのは、A２３セルの様に、【メモ】の文字が二つある行がある点です。

詳しい方、よろしくお願い致します。

回答No.2

tom04 · ベストアンサー

No.1です。

前回のコードで罫線部分の範囲が間違っていました。

＞With Range(Cells(lastRow, "B"), Cells(endRow, "E"))
の行を
＞With Range(Cells(lastRow + 1, "B"), Cells(endRow, "E"))
に変更してください。

これでないとお望み通りの罫線にならないと思います。m(_ _)m

お礼

回答ありがとうございます。

お陰さまで、無事抜き出しが出来ました、感謝いたします。

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

回答No.3

cj_mover

こんにちは。

早速仕様説明です。
万が一にも理論上の無限ループにならないように書くのがマクロのマナーですが、
今回の回答では、サンプルデータの例でＡ８等にメモで始まる文字列が無い場合は、
東京センターを未成立の案件として、コピペしないように書いています。
そんな場合でもデータとしての東京センターを活かす場合は少し書き加えが必要です。
こちらの想定としては、メモを書いた時点で
一連のデータが案件として成立する（でなければ案件として未成立）
というような運用ルールに合わせています。
また、メモで始まる文字列が、センター名や抜き出したい部分に存在する可能性を
排除できない場合は、全く異なるアプローチで書き直すことになります。
ひょっとしてですが、そちらで"リンク"と呼ぶものがハイパーリンクのことではなくて、
相対参照の数式（=A1 等）としてのリンクである場合は、
Copy メソッドに代えて、.Formula = .Formula のようにプロパティを複写するように
書換えることになります。
> ただ1点気になるのは、A２３セルの様に、【メモ】の文字が二つある行がある点です。
"【メモ】の文字が二つある"ことが処理に影響を与える場面が想定出来なかったので、
特別な対策はしていません。不足があれば補足してみてください。
他、幾つかのオプションをコメントとして提示しておきます。
例えば"【日付】　の文字"と呼ぶものが実は、"日付"という文字列のことではなくて、
2014/10/29 のような日付値だった場合は、２択で示した部分のコメントブロックを
入れ替えてください。
連動してＣ列に日付をコピペする記述もオプションとしてコメントブロックしておきます。
動作確認後、不要なオプションは削除して構いません。

処理の流れとしては、
コピー元を総当たりでループして、
日付が見つかったら、行位置だけを記録して、
メモが見つかったら、各データを一斉にコピペします。
抜き出したい部分が複数セルであってもコピペは一度で済ませます。

' ' ///

Sub Re8806004c()
Dim c As Range　'　セル範囲総当たり用変数
Dim nRowDst As Long　'　貼り付け先の先頭行位置
Dim nRowHead As Long　'　日付が見つかった行位置を先頭行として記録
Dim nYSize As Long　'　抜き出したい部分の行数（件数）

　　Application.ScreenUpdating = False　'　option_処理を速める為にExcelの描画を一時停止
　　nRowDst = 1　'　貼り付け先の先頭行位置
　　' ' 貼り付け先を Ｂ１ を基準にした相対参照で指定する★適宜指定 Ｂ１ >
　　With Cells(1, "B")　'　option_貼付け先のシートを指定するなら With Sheets("Sheet2").Cells(1, "A")　等の要領
　　　　' ' コピー元を Ａ列 の１行めから最下行まで として総当たり★適宜指定 Ａ列 >
　　　　For Each c In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)　'　option_コピー元のシート指定可
　　　　　　If c = "日付" Then　'　「日付」という文字列の▼場合（１／２択）
'　　　　　　If IsDate(c) Then　'　もしかして....日付値の▲場合（２／２択）
　　　　　　　　nRowHead = c.Row　'　日付が見つかった行位置を先頭行として記録
　　　　　　ElseIf InStr(c, "メモ") = 1 Then　'　「メモ」という文字で始まる文字列の場合▼場合（１／２択）
'　　　　　　ElseIf InStr(c, "メモ") > 0 Then　 '　「メモ」という文字を含む文字列の場合▲場合（２／２択）
　　　　　　　　nYSize = c.Row - nRowHead - 2　'　抜き出したい部分の行数取得
　　　　　　　　c.Offset(-nYSize - 1).Copy .Cells(nRowDst, 1) '　センター名●●コピペ　相対参照で１列めへ貼り付け
'　　　　　　　　c.Offset(-nYSize - 2).Copy .Cells(nRowDst, 2)　'　option_日付●●コピペ　相対参照で２列めへ貼り付け
　　　　　　　　c.Offset(-nYSize).Resize(nYSize).Copy .Cells(nRowDst, 3)　'　抜き出したい部分●●コピペ　相対参照で３列めへ貼り付け
　　　　　　　　c.Copy .Cells(nRowDst, 4)　'　メモ●●コピペ　相対参照で４列めへ貼り付け
　　　　　　　　With .Cells(nRowDst, 1).Resize(nYSize, 4)
　　　　　　　　　　.BorderAround xlContinuous, xlThin　'　罫線で囲む
'　　　　　　　　　　.Interior.Color = c.Interior.Color　'　option_背景色を案件ごとに統一
　　　　　　　　End With
　　　　　　　　nRowDst = nRowDst + nYSize　'　貼り付け先の先頭行位置
　　　　　　End If
　　　　Next
　　　　.Resize(nRowDst - 1, 4).Columns.AutoFit　'　option_貼り付け先の列幅を最適化
　　End With
End Sub

' ' ///

回答No.1

tom04

こんばんは！
一例です。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long, endRow As Long
Application.ScreenUpdating = False
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "A") = "日付" Then
lastRow = Cells(Rows.Count, "D").End(xlUp).Row
k = i + 1
Cells(k, "A").Copy Cells(lastRow + 1, "B")
Do While Not Cells(k, "A") Like "*メモ*"
k = k + 1
Loop
Range(Cells(i + 2, "A"), Cells(k - 1, "A")).Copy Cells(lastRow + 1, "D")
Cells(k, "A").Copy Cells(lastRow + 1, "E")
endRow = Cells(Rows.Count, "D").End(xlUp).Row
With Range(Cells(lastRow, "B"), Cells(endRow, "E"))
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
End With
i = k
End If
Next i
Range("B1:E1").Delete shift:=xlUp
Range(Columns(2), Columns(5)).AutoFit
Application.ScreenUpdating = True
End Sub

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