こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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
'---------------------------
以上

投稿日時 - 2011-11-20 19:58:47

QNo.7144778

すぐに回答ほしいです

質問者が選んだベストアンサー

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

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

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

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

最終的に、7列で書出しなのか1列で書出しなのかよくわかりませんが
効率良く処理しようと思えば配列にて処理します。
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() '1列書出し
  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
'-------------------------------------------------
..こんな感じです。


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

投稿日時 - 2011-11-21 23:00:44

補足

end-uさん、大変お世話になっております。
やりたい事が本サンプルコードで全て適いました…感謝(5星)
次の関数の意味合いも理解できたつもりです。
サンプルがあって初めて解ったことです…活用させていただきます。
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に失敗しました
-------------------------
以上

投稿日時 - 2011-11-22 12:48:11

ANo.4

このQ&Aは役に立ちましたか?

2人が「このQ&Aが役に立った」と投票しています

回答(6)

ANo.6

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

投稿日時 - 2011-11-23 01:19:42

お礼

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

投稿日時 - 2011-11-23 03:35:46

ANo.5

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

投稿日時 - 2011-11-23 00:53:56

お礼

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

投稿日時 - 2011-11-23 03:34:14

ANo.3

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

投稿日時 - 2011-11-21 01:00:08

補足

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

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

投稿日時 - 2011-11-21 22:17:31

ANo.2

そこそこ出来ているのだろうがシコシコやるだけでは。
質問の画像の部分のシートのデータ例をテキストで貼り付けてないから、テストが手間がかかる。回答者のことも考えて。
例データ
A2
a
b
c
B2
X
y
C2
e
f
g
h
D2
s
d
v
w
k
A3
s
d
f
B3
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
各列10行目から書き出すとする。
結果
A10:D15に
aXes
byfd
csgv
sjhw
dーーk
f
こんなのじゃないか。質問画像例に一部沿ってない。使うなら質問者で修正すること。
ーーーー
わたしなら
DataObjectやGetFromClipboardや.GetTextやReplaceなど難しいのは使わないね。
ロジックの良し悪しが影響する例だな。

投稿日時 - 2011-11-20 21:28:04

補足

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

投稿日時 - 2011-11-21 21:33:05

ANo.1

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

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

違かったらすみません。

投稿日時 - 2011-11-20 21:11:39

あなたにオススメの質問