こういうことがやりたいです。
１、新規ブック作成 ２、1997フォルダー内の19970303日報1を開きA1:K38をコピーし新ブック（sheet1）A1に貼り付け、次に19970303日報2を開きB3:K36をコピーし新ブック（sheet1）L5に貼り付ける。名前をつけて保存（新ブックのK2をファイル名にする）。すべて閉じる。また1からはじめ、同じ作業を次のファイル19970304日報1、19970304日報2に対して行う。
日報ファイルはファイル名が日付になっているため順番に並んでいます。またシートは１つです。
前にこのサイトで教えていた大ことを参考に作ってみましたが、日報ファイルが開いてコピーまでは動いていますが、貼り付けができないです。また名前をつけて保存もできないです。
初心者のため完全に理解して作っていなくておはづかしいですがご教授よろしくお願いします。
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
こういうことがやりたいです。
１、新規ブック作成 ２、1997フォルダー内の19970303日報1を開きA1:K38をコピーし新ブック（sheet1）A1に貼り付け、次に19970303日報2を開きB3:K36をコピーし新ブック（sheet1）L5に貼り付ける。名前をつけて保存（新ブックのK2をファイル名にする）。すべて閉じる。また1からはじめ、同じ作業を次のファイル19970304日報1、19970304日報2に対して行う。
日報ファイルはファイル名が日付になっているため順番に並んでいます。またシートは１つです。
前にこのサイトで教えていた大ことを参考に作ってみましたが、日報ファイルが開いてコピーまでは動いていますが、貼り付けができないです。また名前をつけて保存もできないです。
初心者のため完全に理解して作っていなくておはづかしいですがご教授よろしくお願いします。
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
こういうことがやりたいです。
１、新規ブック作成 ２、1997フォルダー内の19970303日報1を開きA1:K38をコピーし新ブック（sheet1）A1に貼り付け、次に19970303日報2を開きB3:K36をコピーし新ブック（sheet1）L5に貼り付ける。名前をつけて保存（新ブックのK2をファイル名にする）。すべて閉じる。また1からはじめ、同じ作業を次のファイル19970304日報1、19970304日報2に対して行う。
日報ファイルはファイル名が日付になっているため順番に並んでいます。またシートは１つです。
前にこのサイトで教えていた大ことを参考に作ってみましたが、日報ファイルが開いてコピーまでは動いていますが、貼り付けができないです。また名前をつけて保存もできないです。
初心者のため完全に理解して作っていなくておはづかしいですがご教授よろしくお願いします。
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
こういうことがやりたいです。
１、新規ブック作成 ２、1997フォルダー内の19970303日報1を開きA1:K38をコピーし新ブック（sheet1）A1に貼り付け、次に19970303日報2を開きB3:K36をコピーし新ブック（sheet1）L5に貼り付ける。名前をつけて保存（新ブックのK2をファイル名にする）。すべて閉じる。また1からはじめ、同じ作業を次のファイル19970304日報1、19970304日報2に対して行う。
日報ファイルはファイル名が日付になっているため順番に並んでいます。またシートは１つです。
前にこのサイトで教えていた大ことを参考に作ってみましたが、日報ファイルが開いてコピーまでは動いていますが、貼り付けができないです。また名前をつけて保存もできないです。
初心者のため完全に理解して作っていなくておはづかしいですがご教授よろしくお願いします。
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
こういうことがやりたいです。
１、新規ブック作成 ２、1997フォルダー内の19970303日報1を開きA1:K38をコピーし新ブック（sheet1）A1に貼り付け、次に19970303日報2を開きB3:K36をコピーし新ブック（sheet1）L5に貼り付ける。名前をつけて保存（新ブックのK2をファイル名にする）。すべて閉じる。また1からはじめ、同じ作業を次のファイル19970304日報1、19970304日報2に対して行う。
日報ファイルはファイル名が日付になっているため順番に並んでいます。またシートは１つです。
前にこのサイトで教えていた大ことを参考に作ってみましたが、日報ファイルが開いてコピーまでは動いていますが、貼り付けができないです。また名前をつけて保存もできないです。
初心者のため完全に理解して作っていなくておはづかしいですがご教授よろしくお願いします。
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
PowerPoint VBAで複数のユーザーフォームからなるVBAマクロを作成しました。
フォーム内の「次へ」「前へ」ボタンでのみ、マクロの実行制御をしているので、途中で右上の×を押されると、想定外エラーが発生します。
そこで、一番下に貼りつけたようなコードを全てのフォームに挿入することで、右上の×が表示されないようにしました。
あくまでフォームにしかコードは埋め込んでいません。
（標準モジュール、クラスには入ってません）
ですが、極稀に、「フォームの右上×」ではなく、「PowerPointの右上×」が非表示になってしまう現象が発生します。
いろいろやるうちに再現はするのですが、厳密な再現手順がよくわかりません。
状況と下記ソースから、どこらへんに原因がありそうかアドバイス頂けないでしょうか？
全コードは出せない部分が多いのですが、アドバイスにあたり必要なコードがあれば、別途貼らせて頂きます。
Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000
' ウィンドウに関する情報を返す
Private Declare Function GetWindowLong Lib "USER32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
' ウィンドウの属性を変更
Private Declare Function SetWindowLong Lib "USER32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
' Activeなウィンドウのハンドルを取得
Private Declare Function GetActiveWindow Lib "USER32.dll" () As Long
' メニューバーを再描画
Private Declare Function DrawMenuBar Lib "USER32.dll" (ByVal hWnd As Long) As Long
' フォームアクティブ時処理
Private Sub UserForm_Activate()
Dim hWnd As Long
Dim Wnd_STYLE As Long
hWnd = GetActiveWindow()
Wnd_STYLE = GetWindowLong(hWnd, GWL_STYLE)
Wnd_STYLE = Wnd_STYLE And (Not WS_SYSMENU)
SetWindowLong hWnd, GWL_STYLE, Wnd_STYLE
DrawMenuBar hWnd
End Sub
