こういうことがやりたいです。
1、新規ブック作成 2、1997フォルダー内の19970303日報1を開きA1:K38をコピーし新ブック(sheet1)A1に貼り付け、次に19970303日報2を開きB3:K36をコピーし新ブック(sheet1)L5に貼り付ける。名前をつけて保存(新ブックのK2をファイル名にする)。すべて閉じる。また1からはじめ、同じ作業を次のファイル19970304日報1、19970304日報2に対して行う。
日報ファイルはファイル名が日付になっているため順番に並んでいます。またシートは1つです。
前にこのサイトで教えていた大ことを参考に作ってみましたが、日報ファイルが開いてコピーまでは動いていますが、貼り付けができないです。また名前をつけて保存もできないです。
初心者のため完全に理解して作っていなくておはづかしいですがご教授よろしくお願いします。
Sub copybook7()
Dim myPath As String 'このブックのパス
Dim DataFile As String 'Dir()で開くブック名
Dim copybook As Workbook '開いたブック
Dim DataSht As Worksheet 'このブックの貼り付けシート
Dim i As Long '貼り付け行カウンタ
Workbooks.Add
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
With ActiveSheet.PageSetup
Range("A1:G1,L1:AG1").ColumnWidth = 9
Range("H1:K1,AH1").ColumnWidth = 12
End With
With ThisWorkbook
Set DataSht = .Worksheets(1)
myPath = "C:\1997\"
DataFile = Dir(myPath & "*.xls", vbNormal)
i = 1
Do While DataFile <> ""
If DataFile <> .Name And _
InStr(1, DataFile, "日報") > 0 Then
Set copybook = Application.Workbooks.Open( _
Filename:=myPath & DataFile, ReadOnly:=True)
If InStr(1, DataFile, "日報1") > 0 Then
copybook.ActiveSheet.Range("A1:K38").Copy
DataSht.Range("A1").PasteSpecial Paste:=xlAll
ElseIf InStr(1, DataFile, "日報2") > 0 Then
copybook.ActiveSheet.Range("B3:K36").Copy
DataSht.Range("L5").PasteSpecial Paste:=xlAll
Else
End If
Application.DisplayAlerts = False
copybook.Close SaveChanges:=False
Application.DisplayAlerts = True
Set copybook = Nothing
End If
DataFile = Dir
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Range("K2") & "日報"
.Close
Loop
Set DataSht = Nothing
End With
End Sub
No.3ベストアンサー
- 回答日時:
#1です。
個人用マクロブック=自分自身という意味です。
個人用マクロブックがどういう物かは分かりませんがとりあえず実行用のブックが日報と同じフォルダに入っているとして改修した以下のプログラムをお試しください。
Sub copybook7()
Dim MyPath As String 'このブックのパス
Dim DataFile As String 'Dir()で開くブック名
Dim CopyBook As Workbook '開いたブック
Dim NewBook As String '新しいブック
Dim NewFileName As String '新しいファイル名
MyPath = ThisWorkbook.Path & "\"
DataFile = Dir(MyPath & "*.xls", vbNormal)
Do While DataFile <> ""
If DataFile <> ThisWorkbook.Name And InStr(1, DataFile, "日報") > 0 Then
Set CopyBook = Application.Workbooks.Open(Filename:=MyPath & DataFile, ReadOnly:=True)
Select Case Mid(DataFile, 9, 3)
Case "日報1"
Workbooks.Add
NewBook = ActiveWorkbook.Name
With Workbooks(NewBook).ActiveSheet
.PageSetup.PrintTitleRows = ""
.PageSetup.PrintTitleColumns = ""
.Range("A1:G1,L1:AG1").ColumnWidth = 9
.Range("H1:K1,AH1").ColumnWidth = 12
End With
CopyBook.ActiveSheet.Range("A1:K38").Copy
Workbooks(NewBook).ActiveSheet.Range("A1").PasteSpecial Paste:=xlAll
Application.CutCopyMode = False
CopyBook.Close
Case "日報2"
CopyBook.ActiveSheet.Range("B3:K36").Copy
Workbooks(NewBook).ActiveSheet.Range("L5").PasteSpecial Paste:=xlAll
Application.CutCopyMode = False
CopyBook.Close
Application.DisplayAlerts = False
NewFileName = Workbooks(NewBook).ActiveSheet.Range("K2").Value & "日報.xls"
Workbooks(NewBook).SaveAs MyPath & NewFileName
Application.DisplayAlerts = True
Workbooks(NewFileName).Close
End Select
End If
DataFile = Dir
Loop
MsgBox ("完了")
End Sub
この回答への補足
ありがとうございます。
日報ファイルが開くだけです。
新規のファイルを作り、それに既存のファイルの内容をコピーし名前を付けて保存。また新規のファルを作り、そこへ次の既存のファイルをコピーし名前を付けて保存という作業なのですが、、、。
No.6
- 回答日時:
#1です。
NewFileName = Workbooks(NewBook).ActiveSheet.Range("K2").Value & "日報.xls"
を次のように変更してください。
NewFileName = Format(Workbooks(NewBook).ActiveSheet.Range("K2").Value, "yyyymmdd") & "日報.xls"
K2の値が日付であれば「20100203日報.xls」と言う名前になります。
No.5
- 回答日時:
こんな感じでは?
Sub copybook7()
Dim myPath As String 'このブックのパス
Dim DataFile As String 'Dir()で開くブック名
Dim copybook As Workbook '開いたブック
Dim AddBook As Workbook '新規book
Dim i As Long '貼り付け行カウンタ
myPath = "C:\1997\"
DataFile = Dir(myPath & "*.xls", vbNormal)
Do While DataFile <> ""
If DataFile <> .Name And _
InStr(1, DataFile, "日報") > 0 Then
Set copybook = Application.Workbooks.Open( _
Filename:=myPath & DataFile, ReadOnly:=True)
If InStr(1, DataFile, "日報1") > 0 Then
copybook.Worksheets(1).Copy
Set AddBook = ActiveWorkbook
ElseIf InStr(1, DataFile, "日報2") > 0 Then
With AddBook.Worksheets(1)
copybook.Worksheets(1).Range("B3:K36").Copy AddBook.Worksheets(1).Range("l5")
.PageSetup.PrintTitleRows = ""
.PageSetup.PrintTitleColumns = ""
.Range("A1:G1,L1:AG1").ColumnWidth = 9
.Range("H1:K1,AH1").ColumnWidth = 12
AddBook.SaveAs Filename:=myPath & Format(.Range("K2").Value, "yyyymmdd") & "日報" _
, FileFormat:=xlNormal
End With
ActiveWindow.Close
Set AddBook = Nothing
End If
Application.DisplayAlerts = False
copybook.Close SaveChanges:=False
Application.DisplayAlerts = True
Set copybook = Nothing
End If
DataFile = Dir
Loop
End Sub
参考まで
No.4
- 回答日時:
#1です。
補足を頂きました件ですが日報を開いているということは
Select Case Mid(DataFile, 9, 3)
の値が処理に影響していると思われます。
質問の中で「19970303日報1」とあったのでMIDで9文字目から3文字抜き取り処理をするようコーディングしました。
仮に199733日報1のようなファイル名があった場合は何も処理されないです。
Select Case Mid(DataFile, 9, 3)
を
Select Case Mid(DataFile, InStr(1, DataFile, "日報"), 3)
に変更して見てください。
一応こちらで数日分のデータを作り実行してみましたが正常な動作を確認しました。
この回答への補足
すみません省略してしまって。
開いたのは970303日報1・970303日報2、970304日報1・970304日報2・・・・と目的のファイルは開いたのですが、新規のブックに貼付けされていない、保存されていないということです。
ちなみに、エクセルを起動して、PERSONAL.XLSB!copybook7()を実行すると、"完了"の表示だけがされます。970303日報1と同じフォルダー(1997)内にBOOK1を作りそれにプロシージャを登録して、それを開いて実行すると、970303日報1等のファイルは開くのですが、1997フォルダーには新規のファイルは保存されておらず、また、開いているBOOK1にも何も張り付けられていません。
どこがおかしいのでしょうか?
すみませんようやく動きました。
只1つ問題なのは、ファイル名につける参照のセルが1997/03/03なので
このままではファイル名がつけられません。
方法としては
1.1997/03/03を別な表記に変えて保存する。
2.最初にコピーするブック名が970303日報1なので、このファイル名の 970303日報をファイル名にする。
3.970303日報1のファイル名のまま別なフォルダーに保存する。
お忙しいところすみません。よろしくお願いします。
No.2
- 回答日時:
#1です。
環境を合わせて実行してみましたが全体的に改修が必要ですので若干お時間を頂きます。
(他の方が回答されるのが早いかもしれませんが・・・。)
ご提示されておられるのコードの流れは現状以下のようになっています。
自分自身をAとした時
新規ブックZを作成しページ設定を行う。
Aのシート1の名前をDataShtにセット。
フォルダ内のエクセルを読んでくる。
(最初に読み込まれたのが日報1と仮定)
日報1のA1:K38をコピーする。
AのDataShtのA1に貼り付けをする。
日報1を閉じる。
次のファイルを読んでくる。
Aを~日報と言う名前で保存
Aを閉じる。
この時点で新規ブックはページ設定が行われた状態で残りAが終了する為マクロも停止。
ThisWorkbookとActiveWorkbookの使い方が間違っているだけかと思いましたが新規ブック作成のコードがループの外にある為仮に日報2を読んできたとしても貼り付けが出来なくなります。
この回答への補足
すみません、私の勘違いでしょうか、個人用マクロブックにプロシージャーを作り、何も開いていない状態で(自分自身Aが無い状態で新しいブックZを作り、、、という動作を考えていたのですが、これって間違いなのでしょうか?
補足日時:2010/02/01 12:04No.1
- 回答日時:
こんにちは。
現在動作確認を行っておりますが不明な点があります。
>日報ファイルが開いてコピーまでは動いていますが
とありますが、その前に1回目のループで
With ThisWorkbook~.Close
で自身を終了していますがこれはActiveWorkbookの方かと思います。
新たに作った日報1枚を残して終了されていませんか?
この回答への補足
どうもありがとうございます。
すみません、完全に理解して作ったわけではないのでご迷惑をおかけします。
自分としては、新たに作ったブックに日報1、日報2をコピーして
出来たブックのK2のセルをファイル名にして保存して閉じる。(全てを)
その後にまた新しいブックを作り次の日報1,2をコピーして,,,
という動作を考えているのですが、すみません見様見真似ですので
、、正直ご質問の”新たに作った日報1枚を残して終了されていませんか?”は自分でもわからないです。
すみませんがよろしくお願いします。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【前回の続き続きです、ご教示ください】VBAの記述方法がわかりません。 2 2022/08/24 20:49
- Visual Basic(VBA) 【ご教示ください】VBAの記述方法がわかりません。 2 2022/08/12 21:28
- Visual Basic(VBA) 【前回の続きです、ご教示ください】VBAの記述方法がわかりません。 2 2022/08/16 16:44
- Visual Basic(VBA) vbaのエラー対応(実行時エラー7:メモリが不足しています) 4 2023/04/24 00:20
- Visual Basic(VBA) エクセルのマクロを使ってメールを送る方法について教えてください 2 2022/03/29 01:36
- Visual Basic(VBA) VBAのユーザーフォームのテキストボックスに入力制限をしたい 6 2022/11/15 08:28
- Visual Basic(VBA) InputBoxでキャンセルボタンを押したらファイル自体を閉じたい 3 2022/07/23 17:52
- その他(Microsoft Office) マクロVBAについて 1 2022/09/06 18:12
- Visual Basic(VBA) 貼り付けた値が消えていく 以下はソースファイルの2番目のシートのB6から最終行を取得 ターゲットファ 2 2023/07/27 12:23
- Visual Basic(VBA) このVBAでExcelアプリケーションを作成は必要ですか? 3 2023/07/19 21:13
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルを共有するとPCによっ...
-
VBAでブックを非表示で開いて処...
-
WorkBooksをオープンさせずにシ...
-
エクセルの関数 ENTERを押...
-
Excelでブックの共有を掛けると...
-
【ExcelVBA】シートをそれぞれ...
-
エクセルで参照しているデータ...
-
エクセルシートの一部を送りたい
-
ブックのピボットを別ブックに...
-
エクセルで別ブックをバックグ...
-
フォルダ内の複数ファイルから...
-
Excelで指定範囲のデータ...
-
Excelで複数ブックの同一セルに...
-
エクセルで「ディスクがいっぱ...
-
VBA バックグラウンドで別ブッ...
-
VBAでブック保護非保護を判定す...
-
フォルダ内の複数ファイルから...
-
Excelファイルを開いても何も表...
-
エクセルで複数のシートを別フ...
-
アクセスvbaでエクセルブックを...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルの関数 ENTERを押...
-
VBAでブックを非表示で開いて処...
-
エクセルを共有するとPCによっ...
-
WorkBooksをオープンさせずにシ...
-
エクセルで参照しているデータ...
-
エクセルで「ディスクがいっぱ...
-
Excelでブックの共有を掛けると...
-
Excelで複数ブックの同一セルに...
-
Excel(2010)のフィルターが保...
-
エクセルで別ブックをバックグ...
-
エクセルにおける,「ブック」...
-
同じフォルダへのハイパーリン...
-
ブックのピボットを別ブックに...
-
エクセルファイルを開かずにpdf...
-
エクセル2016です。「ブッ...
-
ブックの保護ができないんです...
-
エクセルで50行ごとに区切った...
-
エクセルシートの一部を送りたい
-
フォルダ内の複数ファイルから...
-
エクセル 複数のブックを一度...
おすすめ情報