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

Question

セル[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
'---------------------------
以上

end-u · Accepted Answer

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

結局、
>[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 · Answer

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

end-u · Answer

>ヘルプ
>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 · Answer

>[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くらいの難易度で、それが難しいから使わないってなんだか
#向上心が無いようにも聞こえますね。
#まぁ、いろんな人がいますから別に全否定するつもりは無いですけど。

imogasi · Answer

そこそこ出来ているのだろうがシコシコやるだけでは。
質問の画像の部分のシートのデータ例をテキストで貼り付けてないから、テストが手間がかかる。回答者のことも考えて。
例データ
Ａ２
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
各列１０行目から書き出すとする。
結果
Ａ１０：Ｄ１５に
aXes
byfd
csgv
sjhw
dーーk
f
こんなのじゃないか。質問画像例に一部沿ってない。使うなら質問者で修正すること。
ーーーー
わたしなら
DataObjectやGetFromClipboardや.GetTextやＲｅｐｌａｃｅなど難しいのは使わないね。
ロジックの良し悪しが影響する例だな。

daichimax · Answer

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

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

違かったらすみません。

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

失礼。

この回答への補足

ぁ、失礼。

>ヘルプ

>[A1:A5]とか[B1:B5]…は上手く張り付きますが、

この回答への補足

そこそこ出来ているのだろうがシコシコやるだけでは。

この回答への補足

セル[A11]直下って、

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング