Excel-VBA セルのデータ書出し(Q2)

質問

セル[A1:G5]に次の様なデータが適当に在るとします。
各セル内のデータ数は様々で空のセルも在ります。
セルの書式設定は「折り返して全体を表示する」です。
'----------
中国
'----------
鳥取県　　←各データは[Alt]+[Enter]で改行。
島根県
'----------
岡山県
広島県
山口県
'----------
▼やりたい事は、セル[A1:G5]のデータを、
セル[A11]直下へ次々と書き出したいのですが、
選択範囲が、
[A1:A5]とか[B1:B5]…は上手く張り付きますが、
[A1:G1]とか[A1:G5]…は上手く張り付きません!?
ご教授宜しくお願い致します。
'---------------------------
Sub test22() '行列のデータ範囲を選択して実行
Dim s As String
Selection.Copy
With New DataObject
.GetFromClipboard
s = .GetText
.Clear
.SetText Replace$(s, """", "")
.PutInClipboard
End With
ActiveSheet.Paste Range("A11")
End Sub
'---------------------------
以上

回答No.4

end-u · ベストアンサー

失礼。# のあとは独り言なので気にしないでください。
別に質問者さん宛ではないです。

結局、
>[A11]直下に全て書き出す..
..ように仕様変更ですか？
そのコードで空白セルを詰めるなら最後にまとめて

On Error Resume Next
Range("A11", Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
On Error GoTo 0

こんな簡易処理でも良いかと思いますが。

最終的に、７列で書出しなのか１列で書出しなのかよくわかりませんが
効率良く処理しようと思えば配列にて処理します。
Split関数の結果は配列ですから、そこの基本的理解は大丈夫だと解釈して
'-------------------------------------------------
Sub test5() '行列書出し
　　Const MX As Long = 100 '書出し用配列の最大行数（多めに
　　Dim i　As Long
　　Dim j　As Long
　　Dim cx As Long
　　Dim rx As Long
　　Dim v, w, wi

　　With Range("A1:G5")
　　　　cx = .Columns.Count
　　　　ReDim v(1 To MX, 1 To cx)
　　　　For i = 1 To cx
　　　　　　w = Application.Transpose(.Columns(i))
　　　　　　w = Split(Join(w, vbLf), vbLf)
　　　　　　j = 0
　　　　　　For Each wi In w
　　　　　　　　If Len(wi) > 0 Then
　　　　　　　　　　j = j + 1
　　　　　　　　　　v(j, i) = wi
　　　　　　　　End If
　　　　　　Next
　　　　　　If rx < j Then
　　　　　　　　rx = j
　　　　　　End If
　　　　Next
　　End With
　　Range("A11").Resize(rx, cx).Value = v
End Sub
'-------------------------------------------------
Sub test6() '１列書出し
　　Const MX As Long = 1000
　　Dim i As Long
　　Dim j As Long
　　Dim v(1 To MX, 1 To 1)
　　Dim w

　　With Range("A1:G5").Columns
　　　　For i = 1 To .Count
　　　　　　For Each w In Split(Join(Application.Transpose(.Item(i)), vbLf), vbLf)
　　　　　　　　If Len(w) > 0 Then
　　　　　　　　　　j = j + 1
　　　　　　　　　　v(j, 1) = w
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　End With
　　Range("A11").Resize(j).Value = v
End Sub
'-------------------------------------------------
..こんな感じです。

では、この辺で。あとは工夫してみてください。

補足

end-uさん、大変お世話になっております。
やりたい事が本サンプルコードで全て適いました…感謝(５星)
次の関数の意味合いも理解できたつもりです。
サンプルがあって初めて解ったことです…活用させていただきます。
w = Application.Transpose(.Columns(i))
w = Split(Join(w, vbLf), vbLf)
Range("A11", Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp

ヘルプ
ANo.3 前回の試行では動作したのですが、今日は何故だか実行エラーが出ます!?
その都度、[デバッグ(D)]⇒[ステップイン(F8)]をクリックすれば次に進みますが、
何故実行エラーが発生するのでしょうか!?
勿論、参照設定「Microsoft Forms 2.0 Object Library」(FM20.DLL)はチェックしてあります。
-------------------------
Microsoft Visual Basic
実行エラー '2147221040(800401d0)':
DataObject:GetFromClipboard OpenClipboardに失敗しました
-------------------------
以上

回答No.6

end-u

ぁ、失礼。
>Range("A11", Cells(Rows.Count, 1).End(xlUp)).Clear
初回にこれだとA5データまで消えてしまう恐れがありました..orz
Range("A11", Cells(Rows.Count, 1).End(xlUp).Offset(1)).Clear
..などで。

お礼

end-uさん、
今回は何かと大変お世話になりました。
.Offset(1)という書き方があるのですね^^
また一つ勉強になりました。

回答No.5

end-u

>ヘルプ
>ANo.3 前回の試行では動作したのですが、今日は何故だか実行エラーが出ます!?
>その都度、[デバッグ(D)]⇒[ステップイン(F8)]をクリックすれば次に進みますが、
>何故実行エラーが発生するのでしょうか!?
確かに実行環境によってはエラーが出ますね。
「OpenClipboardに失敗しました」の文字通り、クリップボードがOpenできないようです。
DataObjectを使うコードはLoopを繰り返す処理には向いてないのでしょう。
そういう事も踏まえて test5,6 を提示してみました。

Win32API関数というものを使って、OpenClipboardできるまで待機する..
という手もありかと思いますが、
冗長になりますし、それほどDataObjectに拘るつもりもないですから、
ここは素直にSplitをメインにした配列処理を使われると良いと思います。

以下はあくまで参考です。
Win32APIではなく、Application.ClipboardFormatsを判定に使って待機する例。
#いずれにしても、エラー処理などで冗長になりますね。

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub test7()
　　Const MX As Long = 100 '待機Loop回数
　　Dim r As Range
　　Dim s As String
　　Dim i As Long
　　Dim j As Long
　　Dim n As Long
　　Dim x

　　On Error GoTo errHndlr
　　Application.ScreenUpdating = False
　　Application.StatusBar = ""
　　Set r = Range("A1:G5")
　　Range("A11", Cells(Rows.Count, 1).End(xlUp)).Clear
　　n = 11
　　With New DataObject
　　　　For i = 1 To r.Columns.Count
　　　　　　'Copy成功するまで待機
　　　　　　For j = 1 To MX
　　　　　　　　r.Columns(i).Copy
　　　　　　　　DoEvents
　　　　　　　　x = Application.ClipboardFormats
　　　　　　　　If UBound(x) > 2 Then Exit For
　　　　　　　　Sleep 100
　　　　　　Next
　　　　　　If j > MX Then
　　　　　　　　Err.Raise 1000
　　　　　　End If

　　　　　　.GetFromClipboard
　　　　　　s = .GetText(1)
　　　　　　.Clear
　　　　　　.SetText Replace$(s, """", "")
　　　　　　.PutInClipboard
　　　　　　ActiveSheet.Paste Cells(n, 1)
　　　　　　n = Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　Next
　　End With
　　On Error Resume Next
　　Range("A11", Cells(n, 1)).SpecialCells(xlCellTypeBlanks).Delete shift:=xlShiftUp
　　On Error GoTo 0
errHndlr:
　　Application.CutCopyMode = False
　　Application.StatusBar = False
　　Set r = Nothing
　　If Err.Number <> 0 Then
　　　　MsgBox Err.Number & "::" & Err.Description
　　End If
End Sub

お礼

end-uさん、
ご丁寧なご教授本当に有難うございました。
今回の課題解決には、
ご推奨の「test5,6」を活用させていただきます。
今後ともよろしくお願いいたします。
以上

回答No.3

end-u

>[A1:A5]とか[B1:B5]…は上手く張り付きますが、
>[A1:G1]とか[A1:G5]…は上手く張り付きません!?
そりゃそうでしょうね。
要件に合わせてコードを書くのは当然です。
ですが、そういった工夫をするのは貴方ですよ。
要件が変わる度に回答者がコードを書くのではありません。

目的に適った処理を行うにはいろんな手法があります。
自分が理解しやすい、実行できる方法で処理してください。
コーディングのテクニックに捉われず、
問題解決する為の工夫を自ら考える事を優先してはどうですか。
つまり、
[A1:A5]とか[B1:B5]が上手くいくんだったら
列ごとに処理すれば良いだけですよね。
難しく考えすぎない事です。

空白セルに対する結果の要件が今ひとつ不明ですが
Sub test3()
　　Dim r As Range
　　Dim s As String
　　Dim i As Long

　　Set r = Range("A1:G5")
　　With New DataObject
　　　　For i = 1 To r.Columns.Count
　　　　　　r.Columns(i).Copy
　　　　　　.GetFromClipboard
　　　　　　s = .GetText
　　　　　　.Clear
　　　　　　.SetText Replace$(s, """", "")
　　　　　　.PutInClipboard
　　　　　　ActiveSheet.Paste Cells(11, i)
　　　　Next
　　End With
End Sub
これくらいで。

空白セルを詰めるんだったら
ジャンプ機能で空白セル選択して削除上詰め、の操作を参考にしてください。

#なんかReplace関数が難しいとかいう意見があるようですが
#はて..？
#目が点ですけど、まぁ難しく感じる人がいるのかもしれません？
#でもReplaceくらいの難易度で、それが難しいから使わないってなんだか
#向上心が無いようにも聞こえますね。
#まぁ、いろんな人がいますから別に全否定するつもりは無いですけど。

補足

end-uさん、引続きご教授いただき有難うございます。
更にReplaceを理解したかったのが本音ですが、
非力な私なのでお手柔らかにお願いしますね。
目的のリストアップは下記に示す通りなのですが、
・[RowA]を増分する様な案しか思いつきません…妙案があれば是非ご教授ください。
・空データは出力不要なのですが…下記ループ内で処理可能でしょうか？

Sub test3_A() '…[A11]直下に全て書き出す様に改善。
Dim R As Range
Dim s As String
Dim i As Long
Dim RowA As Long
Set R = Range("A1:G5")
With New DataObject
For i = 1 To R.Columns.Count
R.Columns(i).Copy
.GetFromClipboard
s = .GetText
.Clear
.SetText Replace$(s, """", "")
.PutInClipboard
RowA = Range("A" & Rows.Count).End(xlUp).Row '…A最終行
If RowA <= 10 Then RowA = 10
'ActiveSheet.Paste Cells(11, i)
ActiveSheet.Paste Cells(RowA + 1, 1)
Next
End With
End Sub

▼リストアップ
北海道-東北‎
北海道
青森県
‎岩手県‎
宮城県
‎秋田県
‎山形県
‎福島県
関東
茨城県
栃木県
‎群馬県‎
:
:

回答No.2

imogasi

そこそこ出来ているのだろうがシコシコやるだけでは。
質問の画像の部分のシートのデータ例をテキストで貼り付けてないから、テストが手間がかかる。回答者のことも考えて。
例データ
Ａ２
a
b
c
Ｂ２
X
y
Ｃ２
e
f
g
h
Ｄ２
s
d
v
w
k
Ａ３
s
d
f
Ｂ３
s
j

とする。
ーー
コード
Sub test01()
Dim k(10)
For i = 1 To 5
k(i) = 10
Next i
For Each cl In Range("a2:G5")
s = Split(cl, Chr(10))
For Each dt In s
MsgBox dt
Cells(k(cl.Column), cl.Column) = dt
k(cl.Column) = k(cl.Column) + 1
Next
Next
End Sub
各列１０行目から書き出すとする。
結果
Ａ１０：Ｄ１５に
a X e s
b y f d
c s g v
s j h w
d ー ー k
f
こんなのじゃないか。質問画像例に一部沿ってない。使うなら質問者で修正すること。
ーーーー
わたしなら
DataObjectやGetFromClipboardや.GetTextやＲｅｐｌａｃｅなど難しいのは使わないね。
ロジックの良し悪しが影響する例だな。

補足

imogasiさん、早々の回答有難うございました。
回答いただいたコードで試行したのですが、私のやりたい事と結果が異なっていました。
しかし、想定外とはいえ有益なサンプルである事に変わりありません。頂いておき機会を見て有効活用させていただきます。
提示いただいたコードを[A11]直下へ全てのデータを書き出すように手入れしたら次の様になりました。
しかし、For Each cl In Range("A1:G5")　だと書出し準が上手く並びません…縦横(TRANSPOSE関数の様な)を入れ替えた様な形式でインプットされれば目的の出力順になるのでしょうが非力な私には次の書き方くらいしか案がありません。今後ともよろしくお願いいたします。
Sub test01_A() '…[A11]直下に全て書き出す様に改善。
Dim k(10), i, s, cl, dt, R
R = 11
For Each cl In Range("A1:G5")
s = Split(cl, Chr(10))
For Each dt In s
Cells(R, 1).Select
Cells(R, 1) = dt
R = R + 1
Next
Next
End Sub

回答No.1

daichimax

セル[A11]直下って、
↓こういうことでしょうか？

Sub test()
Range("A1:G5").Copy Destination:=Range("A11")
End Sub

違かったらすみません。