EXCEL マクロ につきまして

質問

お世話になっております。

以前、同様の質問をさせていただきまして、
その拡張バージョンをつくりたいと考えております。

Sub macro1()
Dim myPath As String
Dim myFile As String
Dim c As Long
Dim LastRowr As Long
Application.ScreenUpdating = False

myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*.xls")

c = 6

Do Until myFile = ""
If myFile <> ThisWorkbook.Name Then
Workbooks.Open Filename:=myPath & myFile
lastrow = Worksheets("特定のシート").Range("A65536").Row

ThisWorkbook.Worksheets(2).Cells(1, c).Resize(lastrow, 1).Value = Worksheets("特定のシート").Range("H1").Resize(lastrow, 1).Value
Workbooks(myFile).Close False
c = c + 1
End If
myFile = Dir()
Loop
Application.ScreenUpdating = True

On Error Resume Next
ActiveSheet.Name = Format(Date, "mmdd")
On Error GoTo 0

End Sub

こちらは"特定のシート"の特定の列（H）のみをひたすらフォーマットに
貼り付けていくものですが、コピペしたい列が増えた場合（数は一定ではない）
のバージョンができればと思っております。

正直まったくわかりません。

1)データが何列あるかは不定
2)行1~3には自動的に何らかのデータが振られてしまっており（連番等）
　データの終わりとして使えそうなのは、行4に「0」が入っていること
　（但し0は非表示にしております）

"特定のシート"名・データがH列から始まる等は変わりません。

現状の記述を改修、もしくは全とっかえでも構いません。
なにとぞよろしくお願い致します。

回答No.2

WindFaller · ベストアンサー

こんばんは。

#1の回答者ですが、失礼ですが、私には、おっしゃっている内容を理解できません。

>コピーしたいデータはH列から始まっています。
>仮にH～J列をコピー貼り付け処理し、I列が”カラ”データである、
>それを判断できるのが、I4セルにゼロが入っている、
>ということになります。

I4セルにゼロが入っているとか、「空欄」だとか、それを「判断する」というのは、何を「判断する」のでしょうか？何をするのでしょうか？コピーを取りやめにするのか、I列飛ばして、J列を貼り付けるのか、ご自分の頭の中にあるものは、言葉にしなければ、こちらには通じません。

>こちらを踏まえて再度ご回答いただけますと幸いです。

こちらが、あなたの言葉を忖度して、その度ごとに、こちらに考えるようなことは、本来の掲示板の趣旨に反します。掲示板の回答者は、基本的には、ご自身が分からない時に、手助けをするもので、依頼を受けてコードを書くというような立場にはありません。もう一度、ご自分が書いたものを読み直し見てください。

たとえ、プログラムが書けなくても、きちんと、理路整然と、ご自分でプログラムを書くように、その流れを書いてください。フローチャートを書いてみれば、どこに、説明が足りないか分かるはずです。

今回は、一部ミスもありましたので、その部分は直しました。

'//
　Dim myPath As String
　Dim myFile As String
　Dim RetVal As VbMsgBoxResult
　Dim c As Long
　Dim LastRow As Long
　Dim mWidth As Long
　Dim Wkb As Workbook
　Const spSHNAME As Variant = "特定のシート"
　Const shNUM As Variant = 2 '貼り付け先シート番号

　Application.ScreenUpdating = False
　myPath = 'ThisWorkbook.Path & "\"
　myFile = Dir(myPath & "*.xls?")
　c = 6

　Do Until myFile = ""
　　If myFile <> ThisWorkbook.Name Then
　　　'実行すべきか判断(不要なら削除可)
　　　RetVal = MsgBox("実行しますか。 " & myFile, vbYesNoCancel)
　　　If RetVal = vbCancel Then
　　　　Exit Sub
　　　ElseIf RetVal = vbNo Then
　　　　GoTo Jump
　　　End If
　　　'ここまで

　　　With Workbooks.Open(Filename:=myPath & myFile)
　　　　Application.EnableEvents = False
　　　　With .Worksheets(spSHNAME)
　　　　　LastRow = .Cells(Rows.Count, 8).End(xlUp).Row
　　　　　mWidth = .Cells(1, Columns.Count).End(xlToLeft).Column - 7 'データの大きさ
　　　　　If mWidth = 1 Then MsgBox "H列を通過してしまいました。", 48: Exit Sub
　　　　End With

　　　　'貼り付け先シートとデータシート
　　　　ThisWorkbook.Worksheets(shNUM).Cells(1, c).Resize(LastRow, mWidth).Value = _
　　　　.Worksheets(spSHNAME).Range("H1").Resize(LastRow, mWidth).Value
　　　　.Close False
　　　　Application.EnableEvents = True
　　　End With
　　　c = c + mWidth + 1
　　End If
Jump:
　　myFile = Dir()
　Loop
EndLine:
　Application.ScreenUpdating = True

　On Error Resume Next
　ActiveSheet.Name = Format(Date, "mmdd")
　If Err.Number > 0 Then
　　MsgBox "シート名の変更に失敗しました。", 48
　End If
　On Error GoTo 0

お礼

ありがとうございました。

補足

再度回答いただきましてありがとうございます。

また言葉足らずで申し訳ありません。

ゼロまたは空欄であれば、それ以降にはデータが無いので、
次のブックに移る（すべてのブックの処理が終われば終了）、
ということです。

まずは回答いただいたコードで試してみたいと思います。

ありがとうございました。

回答No.3

WindFaller

こんばんは。

>I4セルにゼロが入っている、=
>ゼロまたは空欄であれば、それ以降にはデータが無いので、
>次のブックに移る

H列から、最後の行を調べて、LastRow にしているわけですが、
I4がゼロか空白なら、その下のデータはない、というのが、
もしかして、もし、実際にあっても、その下はないとみなす場合は、以下のように書き換えなくてはなりません。できれば、以下は使わないで済んでほしいものです。

　　　'ここまで
'-------------------------------　　
　　　With Workbooks.Open(Filename:=myPath & myFile)
　　　　Application.EnableEvents = False
　　　　With .Worksheets(spSHNAME)
　　　　　If .Range("I4").Value = 0 Or .Range("I4").Value = "" Then 'I4を最終と見ました場合
　　　　　　LastRow = 4
　　　　　Else
　　　　　　LastRow = .Cells(Rows.Count, 8).End(xlUp).Row
　　　　　End If
　　　　　mWidth = .Cells(1, Columns.Count).End(xlToLeft).Column - 7 'データの大きさ
　　　　　If mWidth = 1 Then MsgBox "H列を通過してしまいました。", 48: Exit Sub
　　　　End With
'-------------------------------　　　　
　　　　'貼り付け先シートとデータシート

お礼

まだ試行錯誤しておりますが、あとは自らやってみたいと思います。回答誠にありがとうございました。

回答No.1

WindFaller

こんにちは。

Worksheets(2).Cells(1, c).Resize(LastRow, 1).Value
　c = c + 1

それを、横に貼り付けるということでしょうね。

開いたシートのデータの1行目の右端が本当の最終列なの、それは、ここでは分かりません。

>データの終わりとして使えそうなのは、行4に「0」が入っていること
それは、A4なのか、B4なのか、それとも、ぜんぜん違う所なのか、話が分かりません。
ですから、ある程度のデータの位置関係を示さないと、こちらでは書けませんので、UsedRangeを用いることにしました。つまり、データが入っている所、全てを対象にしました。
ふつうは、Endプロパティで、データの終わり行、列を検索できます。

むろん、元のコードとは違って、
>Lastrow = Worksheets("特定のシート").Range("A65536").Row
これは、エラーは出ないとしても無理の感があります。

少し手を加えてみました。

'//
Sub Macro2()
　Dim myPath As String
　Dim myFile As String
　Dim RetVal As VbMsgBoxResult
　Dim c As Long
　Dim LastRow As Long
　Dim mWidth As Long
　Const spSHNAME As Variant = "特定のシート"

　Application.ScreenUpdating = False
　myPath = ThisWorkbook.Path & "\"
　myFile = Dir(myPath & "*.xls?")
　c = 6
　Do Until myFile = ""
　　If myFile <> ThisWorkbook.Name Then
　　　'実行すべきか対話型にして判断(不要なら削除可)　Yes:実行, No:スキップ, Cancel:マクロ中止
　　　RetVal = MsgBox("実行します。 " & myFile, vbYesNoCancel)
　　　If RetVal = vbCancel Then
　　　　Exit Sub
　　　ElseIf RetVal = vbNo Then
　　　　GoTo Jump
　　　End If
　　　'ここまで

　　　With Workbooks.Open(Filename:=myPath & myFile)
　　　　Application.EnableEvents = False
　　　　With .Worksheets(spSHNAME).UsedRange '"特定のシート,データの大きさが分からないので、UsedRangeを使う
　　　　　LastRow = .Cells(.Cells.Count).Row
　　　　　mWidth = .Cells(.Cells.Count).Column
　　　　End With
　　　　'貼り付け先シートとデータシート
　　　　ThisWorkbook.Worksheets(2).Cells(1, c).Resize(LastRow, mWidth).Value = _
　　　　.Worksheets(spSHNAME).UsedRange.Value
　　　　.Close False
　　　　Application.EnableEvents = True
　　　End With
　　　If c <> 6 Then
　　　　mWidth = c + mWidth + 1
　　　End If
　　End If
Jump:
　　myFile = Dir()
　Loop
EndLine:
　Application.ScreenUpdating = True

　On Error Resume Next
　ActiveSheet.Name = Format(Date, "mmdd")
　If Err.Number > 0 Then
　　MsgBox "シート名の変更に失敗しました。", 48
　End If
　On Error GoTo 0
End Sub

お礼

回答誠にありがとうございました。

補足

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

今、試行できる環境にないのですが、補足をさせていただきます。

コピーしたいデータはH列から始まっています。
仮にH～J列をコピー貼り付け処理し、I列が”カラ”データである、
それを判断できるのが、I4セルにゼロが入っている、
ということになります。

あと本文に書き忘れましたが、ゼロでなく、
「空欄」の場合もあります。すいません。。。

こちらを踏まえて再度ご回答いただけますと幸いです。