電球を取り換えるだけで家族を見守る

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

「Excel-VBA セルのデータ書出し(」の質問画像

このQ&Aに関連する最新のQ&A

A 回答 (6件)

失礼。

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

結局、
>[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
'-------------------------------------------------
..こんな感じです。


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

この回答への補足

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
    • good
    • 0

ぁ、失礼。


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

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

お礼日時:2011/11/23 03:35

>ヘルプ


>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
    • good
    • 0
この回答へのお礼

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

お礼日時:2011/11/23 03:34

>[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

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

補足日時:2011/11/21 22:17
    • good
    • 0

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


質問の画像の部分のシートのデータ例をテキストで貼り付けてないから、テストが手間がかかる。回答者のことも考えて。
例データ
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など難しいのは使わないね。
ロジックの良し悪しが影響する例だな。

この回答への補足

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
    • good
    • 0

セル[A11]直下って、


↓こういうことでしょうか?

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

違かったらすみません。
    • good
    • 0

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aと関連する良く見られている質問

QOpenClipboardに失敗しました(初心者です)

ホームページビルダーで、貼付けを行った後にプレビュー画面を開くとたまに表題のスクリプトエラーが発生します。

エラーに対して、そのまま続けてもキャンセルを選んでも、その後全てのアプリケーションで貼付けができなくなります。

クリップボードには残されているときもあるので、クリップボードから選べば貼付けはできるのですが、Ctrl+Vや右クリックではできないのでとても不便です。

再起動すると直るのですが、他に直し方はないでしょうか?
もしくは、原因が分かればそうならないようにしたいのですが、原因は分かりますでしょうか?

Aベストアンサー

下記のサイトを参考にどうぞ
ビルダーのバグが多いのには
ビックリしますよ

参考URL:http://www.hitobito.net/navipage/con010.asp?navi=hpbuilder_p&CID=20

QエクセルVBAでクリップボード内容をクリア

こんにちは。
エクセルのVBAの処理の中で、ある部分をコピーしてそれを、
貼り付けする処理をしています。
処理終了後、ファイルを閉じるときに、クリップボードに
コピーの内容が残っている旨のメッセージがでてきます。
このメッセージを出さない様に、クリップボードの内容を
クリアするにはどのようにすればよろしいでしょうか?
申し訳ありませんが、お教え頂きますようお願いいたします。

Aベストアンサー

Excel.Application.CutCopyMode = False
Workbooks(fName).Close savechanges:=False

かな。1行目だけでいいかも。

Qエクセル:マクロ「Application.CutCopyMode = False」って?

エクセルのマクロを記録していると

「Application.CutCopyMode = False」

というものがよく出てきますが、これは何でしょう?
どういう意味のものかわかりません。
削除しても差し支えないのもでしょうか?

Aベストアンサー

「Application.CutCopyMode = False」の前で
セルのコピー、または切り取りを行っていると思います。
これは、その操作(セルのコピー、または切り取り)を無効にしているだけです。
------------
Range("A1").Select
Selection.Copy ← これを無効にしている
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
------------
上記の場合であれば、「Application.CutCopyMode = False」を削除しても問題ありませんが、
以下の場合、貼り付け処理でエラーになります。
------------
Range("A1").Select
Selection.Copy
Range("A2").Select
Application.CutCopyMode = False
ActiveSheet.Paste ← ココでエラー
------------
ご自分で、セルをコピーしてみると分かると思いますが、コピーした範囲が点線で点滅されます。
「Application.CutCopyMode = False」をすると、
その点滅がなくなります。

「Application.CutCopyMode = False」の前で
セルのコピー、または切り取りを行っていると思います。
これは、その操作(セルのコピー、または切り取り)を無効にしているだけです。
------------
Range("A1").Select
Selection.Copy ← これを無効にしている
Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
------------
上記の場合であれば、「Application.CutCopyMode = False」を削除しても問題ありませんが、
以下の場合、貼り付け処理でエラーになります。
------------
...続きを読む

QエクセルのIF文で「NOT=」はどう書くのですか?また、>=や<=の場合の書き方を教えてください

タイトルのとおりです

IF文で下記の3つの書き方がわかりません。

NOT=は、<>?
0以外の場合は、A1<>0?

A1が0と同じか、大きい場合は
A1>=0?

なんだか、うまくいきません^^;

よろしくお願いいたします

Aベストアンサー

A1が・・・・・
A1 <> 0  0以外
A1 >= 0  0以上(0を含む)
A1 > 0   0より大きい(0は含まない)
A1 <= 0  0以下(0を含む)
A1 < 0  0未満
A1 = 0  0

=<,=> などの書き方は使えません。

QFunctionの戻り値を配列にしたいのですが

vbを始めたばかりですがよろしくお願いします。

Functionの戻り値を配列にしたいのですが

Function fnc(ByVal a As Byte, ByVal b As Byte) As Integer()
fnc(0) = a + b
fnc(1) = a - b
End Function
というような使い方はできないのでしょうか?
一つのFunctionで二つの計算結果をかえすには
どうしたらよいのでしょうか?
お願いします。

Aベストアンサー

ローカル変数を使えば可能だと思いますよ

VB6.0の場合
Function fnc( byVal a as Byte, Byval b as Byte) as Integer
  dim ar(1) as Integer
  ar(0) = a + b
  ar(1) = a - b
  fnc = ar
End Function

VB.NETなら
Function fnc( byVal a as Byte, Byval b as Byte) as Integer
  dim ar(1) as Integer
  ar(0) = a + b
  ar(1) = a - b
  return ar
End Function

VB.NETでも fnc = ar と言った記述も出来ます

呼び出し側では 動的配列として返り値を受けます
dim results() as Integer
results = fnc( 5, 3 )
と言った具合です

Qメッセージボックスを前面に表示させるには?

Sub 教えて()
Dim ExAp As Application
Dim ExBk As Workbook
Dim ExSh As Worksheet

Set ExAp = CreateObject("Excel.Application")
Set ExBk = ExAp.Workbooks.Add
Set ExSh = ExBk.Worksheets(1)
ExAp.Visible = True
ExAp.WindowState = xlMaximized

ThisWorkbook.Worksheets(1).Activate
MsgBox "前面表示させたいお!"

Set ExAp = Nothing
Set ExBk = Nothing
Set ExSh = Nothing

End Sub
これを実行するとメッセージボックスが隠れてしまいます。
どうしたらよいでしょうか?

Aベストアンサー

自身のアプリケーションにフォーカスを持ってくる
という方法ですが、2種類、3通りの方法があります。
(1)自身のVisibleを切り替える
Application.Visible = False
Application.Visible = True
MsgBox "前面表示させたいお!"
(2)APIを使う方法
(A)WindowsAPIを定義する方法
Declare Function SetForegroundWindow Lib "USER32" _
    (ByVal Hwnd As Long) As Long
Sub 教えて()
SetForegroundWindow Application.Hwnd
MsgBox "前面表示させたいお!"
End Sub
(B)ExecuteExcel4Macroを使う方法
ExecuteExcel4Macro "CALL(""USER32""," _
    & """SetForegroundWindow"",""JJ""," _
    & Application.Hwnd & ")"
MsgBox "前面表示させたいお!"

(1)は簡単ですが、タスクバーでの自身のアイコン位置が
最後尾になってしまう弱点があります。
(2)はSetForegroundWindowで自身のアプリケーションに
フォーカスを取り戻しています。
(A)は正規のAPI定義手法を使っています。
(B)は以前のAPI呼び出しです。

自身のアプリケーションにフォーカスを持ってくる
という方法ですが、2種類、3通りの方法があります。
(1)自身のVisibleを切り替える
Application.Visible = False
Application.Visible = True
MsgBox "前面表示させたいお!"
(2)APIを使う方法
(A)WindowsAPIを定義する方法
Declare Function SetForegroundWindow Lib "USER32" _
    (ByVal Hwnd As Long) As Long
Sub 教えて()
SetForegroundWindow Application.Hwnd
MsgBox "前面表示させたいお!"
End Sub
(B)ExecuteExcel4Macroを使う方法
ExecuteExce...続きを読む

QエクセルVBAでセル範囲のデータをクリップボードに

セル範囲のデータをテキストとしてクリップボードに取り込みたいのです。

http://oshiete.goo.ne.jp/qa/5650002.html#16327676 の回答ANo2を見て

Sub test01()
Dim myData As DataObject
Dim myCb As Variant
Dim x
x = "TESTデータです。"
Set myData = New DataObject
myData.SetText x
myCb = myData.GetText
myData.PutInClipboard
End Sub

は出来ました。
そこで、セル範囲A1:B3をクリップボードに貼ろうといろいろやってみました。
一応、下記でできましたが、実際にはもっと広い範囲を取り込みたいので、もっと簡単な方法はないでしょうか?

Sub Clip()
Dim myStr As String
Dim myData As DataObject
Dim myCb As Variant
Set myData = New DataObject
With Sheets(1)
myStr = .Range("A1").Value & ":" & .Range("B1").Value & _
vbNewLine & .Range("A2").Value & ":" & .Range("B2").Value & _
vbNewLine & .Range("A3").Value & ":" & .Range("B3").Value
End With
myData.SetText myStr ', 1
myCb = myData.GetText

If MsgBox("データ" & vbNewLine & myCb & " をクリップボードに送りますか? ", vbYesNo + vbQuestion, "確認") = vbNo Then
Exit Sub
End If
myData.PutInClipboard
End Sub

セル範囲のデータをテキストとしてクリップボードに取り込みたいのです。

http://oshiete.goo.ne.jp/qa/5650002.html#16327676 の回答ANo2を見て

Sub test01()
Dim myData As DataObject
Dim myCb As Variant
Dim x
x = "TESTデータです。"
Set myData = New DataObject
myData.SetText x
myCb = myData.GetText
myData.PutInClipboard
End Sub

は出来ました。
そこで、セル範囲A1:B3をクリップボードに貼ろうといろいろやってみました。
一応、下記でできましたが、実際には...続きを読む

Aベストアンサー

横いりすみません。

必要範囲をCoryしたら、
DataObjectのGetFromClipboardメソッドを使ってクリップボードデータを取得します。
そこからさらにDataObjectのGetTextメソッドを使うとテキスト文字列だけ取り出せます。
その後、DataObjectをClearして
あらためて取り出したテキスト文字列をSetTextすれば良いです。
各メソッドについては、DataObjectのヘルプを見て下さい。

ただし、OutlookならCtrl+VまでVBAでやれば良い気がしますが。
http://outlooklab.wordpress.com/
この辺りを参考にしてみると良いかと。
Sub try()
  Const olFolderInbox As Long = 6
  Const olMailItem As Long = 0
  Dim obj As Object
  Dim ins As Object
  Dim m  As Object
  Dim tmp As String

  If TypeName(Selection) <> "Range" Then Exit Sub

  Selection.Copy
  With New DataObject
    .GetFromClipboard
    tmp = .GetText
    .Clear
  End With
  Application.CutCopyMode = False

  On Error Resume Next
  Set obj = GetObject(, "Outlook.Application")
  On Error GoTo 0
  If obj Is Nothing Then
    Set obj = CreateObject("Outlook.Application")
    obj.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Display
  End If

  For Each ins In obj.Inspectors
    With ins.CurrentItem
      If .MessageClass = "IPM.Note" Then
        If Not .Sent Then
          Exit For
        End If
      End If
    End With
  Next

  If ins Is Nothing Then
    Set m = obj.CreateItem(olMailItem)
  Else
    Set m = ins.CurrentItem
    Set ins = Nothing
  End If

  m.body = tmp
  m.Display

  Set m = Nothing
  Set obj = Nothing
End Sub

横いりすみません。

必要範囲をCoryしたら、
DataObjectのGetFromClipboardメソッドを使ってクリップボードデータを取得します。
そこからさらにDataObjectのGetTextメソッドを使うとテキスト文字列だけ取り出せます。
その後、DataObjectをClearして
あらためて取り出したテキスト文字列をSetTextすれば良いです。
各メソッドについては、DataObjectのヘルプを見て下さい。

ただし、OutlookならCtrl+VまでVBAでやれば良い気がしますが。
http://outlooklab.wordpress.com/
この辺りを参考にしてみると良いかと...続きを読む

QVBAで配列をまるごとコピー

VBAで配列をまるごとコピーする方法を教えてください

a(256,256)
という配列があり、これの中身を
b(256,256)
にまるごとコピーしたいのですが
どのようにするのが手っ取り早いでしょうか?

Aベストアンサー

手っ取り早いのは、
bをvariantで宣言して、

b=a

とするのが一番手っ取り早いかと。

QエクセルVBAが途中で止まります

以前別のカテゴリで質問したのですが、そちらでは解決出来なかったので、こちらで改めて質問します。
下記のマクロで、一つのブックからSheet1だけをコピーして来て、少し処理をし、元のブックを閉じるというもので、ブックの数は多くて3000程、少ない時は300位です。
で、このマクロだと900位までですと最後まで行くのですが、それを超えるとリストが95位で止まってしまいます。
自宅で別データを作ってやってみるとうまくいきました。
コピー元のブックにはテキストデータのみで、200文字から500文字程度の大きさしかありません。
ファイル名も50文字程度の物を全部20文字程度まで短くしてもみましたが、ダメでした。
どうかお知恵をお貸しください。

Sub ★1★ブックの結合()
Dim sFile As String
Dim sWB As Workbook, dWB As Workbook, aWB As Workbook
Dim dSheetCount As Long
Dim i As Long
Dim SOURCE_DIR As String

'エクセルデータに変換されたファイルのあるフォルダを選択します。
MsgBox "エクセルに変換されたデータのフォルダを選択"
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
SOURCE_DIR = .SelectedItems(1) & "\"
End If
End With

Application.ScreenUpdating = False

'指定したフォルダ内にあるブックのファイル名を取得
sFile = Dir(SOURCE_DIR & "*.xls")

'フォルダ内にブックが無ければ終了
If sFile = "" Then Exit Sub

'集約用ブックを作成
Set dWB = Workbooks.Add

'転記マクロの中のDMリストシートをコピーする
Workbooks("転記用マクロ.xlsm").Worksheets("DMリスト").Copy Before:=dWB.Worksheets("Sheet1")
Application.DisplayAlerts = False
Worksheets(Array("Sheet1", "sheet2", "sheet3")).Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

'集約用ブック作成時のシート数を取得
dSheetCount = dWB.Worksheets.Count

Do
'コピー元のブックを開く
Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)

'コピー元のsheet1を集約用ブックにコピー
sWB.Worksheets("sheet1").Copy After:=dWB.Worksheets(dWB.Sheets.Count)

シート転記

'コピー元ファイルを閉じる
Application.DisplayAlerts = False
sWB.Close
Application.DisplayAlerts = True

'セルA2の名前を変更する


'シート名をセルA2の値に変更
'ActiveSheet.Name = Range("A2").Value


'次のブックのファイル名を取得
sFile = Dir()
Loop While sFile <> ""

'集約用ブックを保存する
'dWB.SaveAs Filename:=DEST_FILE


Application.ScreenUpdating = False


End Sub

以前別のカテゴリで質問したのですが、そちらでは解決出来なかったので、こちらで改めて質問します。
下記のマクロで、一つのブックからSheet1だけをコピーして来て、少し処理をし、元のブックを閉じるというもので、ブックの数は多くて3000程、少ない時は300位です。
で、このマクロだと900位までですと最後まで行くのですが、それを超えるとリストが95位で止まってしまいます。
自宅で別データを作ってやってみるとうまくいきました。
コピー元のブックにはテキストデータのみで、200文字から500文字...続きを読む

Aベストアンサー

http://oshiete.goo.ne.jp/qa/8750372.html


例えば、30ファイルあっても10ファイルしか読み込まれない事があり、
エラーメッセージもない、何事もなく終了するが10ファイルしか処理されていない、
常に発生する訳ではなく、マシンが変われば同じデータでもOKだったり、
データが少し変わればOKだったりする。
なので、昨日までOKだったのに、今日データが変わった為、急にダメになったりする。
もし、10ファイル目で発生した場合、何度実行しても必ず、10ファイル目までしか処理されない。
そのファイルがおかしいかと思い、その前後の2~3ファイルを削除しても、
やっぱり、10ファイル目(さっきとは違うファイル)までしか処理されない、
という恐ろしいバグがExcel VBAにありますが、それじゃないですかね?

While文などのループの中に、ワークブックのオープンがあると、
何度目かでオープンが実行されず、エラーなしでスルンと終わります。

回避方法は、Open 文の前に DoEvets の1行を書く事。
だいたいこれで直りますが、これで直らなかったマクロもあったので、
Open 文の後ろにも DoEvets の1行を書いて、前後を DoEvets ではさむと直りました。
安全(?)の為、前後をはさんでおいた方が良いと思います。

こんな感じ:
DoEvents
Workbooks.Open aaa
DoEvents

かなり前(1年くらい?)にハマりググりまくったところ、ほとんど情報はなかったですが、
1人だけ、自分の質問に「直った」と自己回答している方がいて、Open文の前にDoEvetsをつけたら直ったそうです。
半信半疑で真似たら私も直りました。
何故、これで直るのかはわかりませんが、DoEvetsを外すと見事に再現し、DoEvetsではさむとピタッと直ります。

ググりまくった際、とても情報が少なく、こんなに顕著に再現するのに、
何故、情報が少ないのかは不思議に思いました。

http://oshiete.goo.ne.jp/qa/8750372.html


例えば、30ファイルあっても10ファイルしか読み込まれない事があり、
エラーメッセージもない、何事もなく終了するが10ファイルしか処理されていない、
常に発生する訳ではなく、マシンが変われば同じデータでもOKだったり、
データが少し変わればOKだったりする。
なので、昨日までOKだったのに、今日データが変わった為、急にダメになったりする。
もし、10ファイル目で発生した場合、何度実行しても必ず、10ファイル目までしか処理されない。
そのファイルがおかし...続きを読む


人気Q&Aランキング

おすすめ情報