(excel VBA) データを一列にまとめる（マクロで一気に）

質問

excel2003を使っています

webページ全体を、テキスト形式でシートに貼り付けて
その後必要な部分だけをマクロで抽出するという作業を行っています。

テキスト形式で貼り付けた際、ブックを開いた直後に(一度もマクロを実行してない状態)貼り付けを行うと、すべてのデータがうまくA列に貼り付けられるのですが、

一度マクロを実行させた後、同じように貼り付けを行うと、データがB列やC列に散らばってしまいます。（行の位置は変わりないです）

この解決策が全く思いつかないので、次のマクロを組みました

Range("A1").value = Range("A1").value & Range("B1").value

まとめたい行が100行以上あるので、とりあえずDo～LoopかFor～nextを使って、この記述で１行ずつまとめていく感じです。ただ、一気に列全体をまとめれたほうがスピードが速いと思い、質問いたしました。

そこで
(1)列全体を一気にまとめる方法はありますか？
(2)そもそも貼り付けの段階で、ちゃんとA列にデータがまとまらないのはなぜ？（１回目はできるのに…）

という質問に、お答えいただけないでしょうか？

質問を２つに分けようかとも思ったのですが、関連でしたので、まとめて質問させていただきました。
お力をお貸し願えないでしょうか？

回答No.2

KenKen_SP · ベストアンサー

こんばんは。

> (1)列全体を一気にまとめる方法はありますか？

ループで順次処理していくほかありません。処理速度が気になる
のであれば、

　　Application.ScreenUpdating = False

で画面更新を停止すれば良いかと。既存コードの提示がないので、
これ以上の具体的なアドバイスはしにくいです。

単純にテキストだけほしいなら、IE オブジェクトや HttpRequest
オブジェクトから取得するという手もあります。

> (2)そもそも貼り付けの段階で、ちゃんとA列にデータがまとまらない
> のはなぜ？（１回目はできるのに…）

> 一度マクロを実行させた後、

このマクロの中で、「TextToColumns」メソッドを使っているの
では？

TextToColumns メソッドはテキストをある区切り文字でセルに
分解しますが、ここで行った区切り文字の設定はマクロ実行後も
そのまま残ります。

コピー＆ペーストの操作においても、この区切り文字の設定に
従ってセルに分解されますので、、

# 結局コードを提示しないと全て推測の回答しかできません。。
# なるべくコードを提示した方が良いと思います。

お礼

TextToColumns メソッドはテキストをある区切り文字でセルに
分解しますが、ここで行った区切り文字の設定はマクロ実行後も
そのまま残ります。

なるほどです。
この設定を元に戻すにはどうしたらいいですか？

補足

確かにTextToColumns メソッドを使用しています。
コードは結構長いので、あえて提示しませんでした。
一部提示しますと
Sub クチコミゲッター()

Dim objSheet As Object
Dim intLoop As Integer
Dim copyLoop As Integer

'コピーデータの貼り付け

Sheets("sheet1").Select
Range("A1").Select
ActiveSheet.PasteSpecial Format:="テキスト", _
Link:=False, _
DisplayAsIcon:=False

'【質問の部分です。doLoopで処理しています】

copyLoop = 1

Do
Range("A" & copyLoop).Value = Range("A" & copyLoop).Value & _
Range("B" & copyLoop).Value & _
Range("C" & copyLoop).Value & _
Range("D" & copyLoop).Value
copyLoop = copyLoop + 1

Loop Until copyLoop = 150

'重複データ登録回避

Sheets("sheet2").Select

If Range("D2").Value = 1 Then

Sheets("sheet1").Select
Columns("A:A").Select
Selection.ClearContents

MsgBox "データが重複しています、リストにはこの店舗は登録しません。", , "データの重複"

Exit Sub

Else

Sheets("sheet1").Select

'条件付書式の設定
Cells.Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(A1,""予算*"")"
Selection.FormatConditions(1).Interior.ColorIndex = 39

'リスト整理
　 L = 0
Range("A1:A4").Select
Selection.Cut
Range("B1").Offset(L, 0).Select
ActiveSheet.Paste
L = L + 4

Range("A28:A30").Select
Selection.Cut
Range("B1").Offset(L, 0).Select
ActiveSheet.Paste
L = L + 3

'クチコミ回収
Do
Sheets("sheet2").Select
Y = Range("B1").Value
G = Range("B2").Value
Sheets("sheet1").Select

Range("A" & Y & ":A" & G).Select
Selection.Cut
Range("B1").Offset(L, 0).Select
ActiveSheet.Paste

L = L + G - Y

Range("B1").Offset(L, 0).Select
Selection.ClearContents
Sheets("sheet2").Select

L = L + 1
Loop Until Range("D1").Value = 0

'不要データ削除
Sheets("sheet1").Select
Columns("A:A").Select
Selection.ClearContents

'店名抽出

Range("B1").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=True, Tab:=False, Semicolon _
:=False, Comma:=False, Space:=True, Other:=True, OtherChar:="[", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 9), Array(4, 9)), _
TrailingMinusNumbers:=True

回答No.4

KenKen_SP

処理速度の低下要因としては、画面更新と数式（条件付書式）の
再計算でしょうね。

最大で 150 行程度ならこれらの停止で十分な速度が期待できます。

さらに高速化するとすれば、Select をなるべくしない書き方とか、
#1 ご回答にあるような配列処理などがありますが、今回は数量的に
言って、この程度で良い気がします。

Sub クチコミゲッター()

　　' ～ 略 ～

　　’メインの処理の前で
　　' // 、画面更新と数式の再計算を停止
　　' // コード実行中にエラーが発生した場合、エラーハンドラで
　　' // メッセージを表示した後、Application の設定を元に戻す
　　On Error GoTo ERROR_HANDLER
　　With Application
　　　　.ScreenUpdating = False
　　　　.Calculation = xlCalculationManual
　　End With

　　' ～ 中略 ～

' // 終了処理
TERMINATE:

　　' // TextToColumns の設定を元に戻す
　　' // 適当なセルにダミーテキストを置いて初期状態の設定で
　　' // TextToColumns メソッドを実行する（泥臭いかも^^;）

　　With Range("A1") ’<---空いている適当なセル
　　　　.Value = "RESTORE"
　　　　.TextToColumns DataType:=xlDelimited, _
　　　　　　　　　　　 TextQualifier:=xlDoubleQuote, _
　　　　　　　　　　　 ConsecutiveDelimiter:=False, _
　　　　　　　　　　　 Tab:=True, _
　　　　　　　　　　　 Semicolon:=False, _
　　　　　　　　　　　 Comma:=False, _
　　　　　　　　　　　 Space:=False, _
　　　　　　　　　　　 Other:=False, _
　　　　　　　　　　　 FieldInfo:=Array(1, 1), _
　　　　　　　　　　　 TrailingMinusNumbers:=True
　　　　.ClearContents
　　End With
　　' // Application の設定を元に戻す
　　With Application
　　　　.ScreenUpdating = True
　　　　.Calculation = xlCalculationAutomatic
　　End With
　　Exit Sub

' // エラーハンドラ
ERROR_HANDLER:
　　MsgBox Err.Description, vbCritical
　　Resume TERMINATE ' // 終了処理へ飛ばす
End Sub

お礼

お礼とは異なるのですが、

マクロの途中で、sheet2のD2にあるCOUNTIF関数の値を所得して、その値が０になるまでDOループを続けるという記述があり、最初に
.Calculation = xlCalculationManual
にしておくと計算をしてくれず、ループを抜けることができません。
その場合、いちいち、ループの前後で
.Calculationを変更しなければいけませんか？

補足

１つ１つに丁寧な回答を頂き、大変感謝しています。

表示と再計算の問題ですが、確かに速度低下の原因はそこにあると思います。今のところデータの数が少なかったのと、時間的、能力的な問題で雑な記述が目立ちます。

表示に関しては、マクロの最初に
Application.ScreenUpdating = False
最後に
Application.ScreenUpdating = True
を入れることでずいぶん高速化しました
KenKen_SP様のように、自動計算についての記述を加えるとさらに高速化できると思います。

主にマクロの記録機能を使って独学でマクロを勉強していますので、こういったアドバイスは大変勉強になります。

回答No.3

Wendy02

こんばんは。

>(1)列全体を一気にまとめる方法はありますか？

バラバラになったデータを一気にA列にまとめ上げるマクロ
（おそらくは、空白値があるような気がしますから、数式の中を処理したほうがよいと思います）

Sub TestSample1()
Dim r As Range
Set r = Range("A1", Range("A65536").End(xlUp))
　'6列まで
　r.Offset(, 6).FormulaLocal = "=TRIM(A1&"" ""&B1&"" ""&C1&"" ""&D1&"" ""&E1&"" ""&F1)"
　r.Value = r.Offset(, 6).Value
　ActiveSheet.UsedRange.Offset(, 1).ClearContents
End Sub

>(2)そもそも貼り付けの段階で、ちゃんとA列にデータがまとまらないのはなぜ？（１回目はできるのに…）

>一度マクロを実行させた後、同じように貼り付けを行うと、データがB列やC列に散らばってしまいます。（行の位置は変わりないです）

それは、区切り位置か、QueryTable　を使っているのだと思いますから、ダミーデータを使って、もう一度、元の状態に戻してあげればよいと思います。以下の場合は、デフォルトに戻しています。（以上は、Excel2003のみでしか試験していません）

Sub TestSample2()
　　With Range("A1")
　　.Select
　　.Insert xlShiftDown
　　.Offset(-1).Value = "AAA"　'ダミー
　　.TextToColumns _
　　　　　　 Destination:=Range("A1"), _
　　　　　　 DataType:=xlDelimited, _
　　　　　　 TextQualifier:=xlDoubleQuote, _
　　　　　　 ConsecutiveDelimiter:=False, _
　　　　　　 Tab:=True, _
　　　　　　 Semicolon:=False, _
　　　　　　 Comma:=False, _
　　　　　　 Space:=False, _
　　　　　　 Other:=False, _
　　　　　　 FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
　　.Delete xlShiftUp
　　End With

End Sub

私は、(2)のマクロは、似たような内容を個人用マクロブックに入れて使っています。

補足

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

NO.2様のご指摘どおり、マクロ内でTextToColumnを使っていました。

そこで、マクロの最後に

'区切り位置の修正
Sheets("sheet2").Select
Range("A1").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True

という記述を追加し、対応するとうまくいきました。
Wendy02様の記述とどちらがよいかは当方では判断できませんので、ほぼ同じかな？と思っています。

(1)に関しては、(2)が解決するに及び、記述の必要が無くなったのですが、NO.2様の補足に記述したDOループよりもWendy02様の記述の方がいいように思います。今後同様の処理が必要になった際に参考にさせていただきます。ありがとうございました

回答No.1

merlionXX

(2)はわかりません。

(1)は、高速化ということですので、一旦配列に取り込んで処理したらいかがでしょう？
A列と10列の100行目までを取り込み、A列に戻す例です。

Sub test001()
Dim i As Long
Dim ar As Variant
Dim br(99, 0)
ar = Range("A1:B100").Value
For i = LBound(ar, 1) To UBound(ar, 1)
br(i - 1, 0) = (ar(i, 1) & ar(i, 2))
Next
Range("A1:A100").Value = br
End Sub