Ｐａｇｅ 353 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼何がおかしいのでしょう・・・ ISHIKAWA 02/10/30(水) 17:25 ┗とりあえず りん 02/10/31(木) 0:51 ┗Re:とりあえず KU 02/10/31(木) 16:28 ┗Activeを多用すると混乱するよ りん 02/11/1(金) 10:38 ┗Re:Activeを多用すると混乱するよ KU 02/11/18(月) 14:59 ─────────────────────────────────────── ■題名 ： 何がおかしいのでしょう・・・ ■名前 ： ISHIKAWA ■日付 ： 02/10/30(水) 17:25 -------------------------------------------------------------------------
| いつも教えていただいています。ありがとうございます。 ちょっと長くなりますが・・・。 ＦＤ（Ａドライブ）にあるA.TXTとB.TXTをエクセルに読み込み、 指定したエクセルファイルに書き込み、セーブして終了（エクセルファイルを閉じる）。 という処理を行うために、下記のようなＶＢＡを組みました。 （長くてすみません・・・。） しかし、ファイルには書き込みに行っているみたいなのですが、 セーブして、終了というメッセージ（COMPLETE!)が出てこないし、 エクセルも閉じないのです。 手動でエクセルファイルを閉じることは出来ます。（保存しますか？ というコメントは出てくる） デバック等やってみても引っかかってこないので・・・ 途中でハングしてるのかな？とも思うのですが、うーーーん・・・ わからない・・・。 すみませんがどなたか教えてください！ Option Explicit Dim MSG As String Dim RET As Integer Dim FNAME As String Dim SaveBook As Object 'ACTIVE BOOK NAME SAVE AREA Sub Auto_Open() Set SaveBook = Application.ActiveWorkbook MSG = "A DRIVES IS TEXT FLOPY DISK SETTING OK ?" _ & Chr(13) & Chr(13) & Chr(9) & "Ver 1.0" & Chr(9) _ & "Created by 1997/06/18" RET = MsgBox(MSG, vbYesNo, "OPENS TEXT FILE") If RET = vbNo Then Beep Exit Sub End If RateTextRead RateHyoCopy UsdTextRead UsdHyoCopy Create_Newbook End Sub '********************************************************* ' A TEXT FILE READ PROCESS * '********************************************************* Sub RateTextRead() ' OPEN TEXT FILE NAME SET ' FName = Application.GetOpenFilename("A TEXT FILE(*.txt),*.txt" _ ' , 1, "EXCHANGE A TEXT FILE OPEN") ' FNAME = "A:\A.TXT" If FNAME <> "False" Then MSG = "Opening ... Text File (A.TXT) !!!" DispStatMsg 1, MSG 'STATUS BAR MESSAGE DISPLAY Application.ScreenUpdating = False 'SCRREN LOCK ' '*** TEXT IMPORT WIZARD *** '*** DATA TYPE :DELIMITED '*** DELIMITERS:TAB,COMMA Workbooks.OpenText FileName:=FNAME, _ StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=True, Space:=False, Other:=False, _ FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 2), _ Array(4, 1), Array(5, 2), Array(6, 1), Array(7, 1), _ Array(8, 1), Array(9, 1), Array(10, 1)) DispStatMsg 0 'STATUS BAR MESSAGE CLEAR End If End Sub '********************************************************* ' B TEXT FILE READ PROCESS * '********************************************************* Sub BTextRead() ' OPEN TEXT FILE NAME SET ' FNAME = Application.GetOpenFilename("B TEXT FILE(*.txt),*.txt" _ ' , 1, "B TEXT FILE OPEN") ' FNAME = "A:\B.TXT" If FNAME <> "False" Then MSG = "Opening ... Text File (B.TXT) !!!" DispStatMsg 1, MSG 'STATUS BAR MESSAGE DISPLAY Application.ScreenUpdating = False 'SCRREN LOCK ' '*** TEXT IMPORT WIZARD *** Workbooks.OpenText FileName:=FNAME, _ StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=True, Space:=False, Other:=False, _ FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), _ Array(4, 1), Array(5, 1), Array(6, 1)) DispStatMsg 0 'STATUS BAR MESSAGE CLEAR End If End Sub Sub RateHyoCopy() Dim i, J As Integer Dim RC1, RC2 As Integer 'GYO COUNT Dim CC1, CC2 As Integer 'RETU COUNT MSG = "Copies Text File of RATE to Excel Sheets (A) !!! " DispStatMsg 1, MSG 'STATUS BAR MESSAGE DISPLAY ' Windows(SaveBook.Name).Activate 'A.XLS Worksheets("A").Select With Worksheets("A").Cells(1, 1).CurrentRegion ' RC1 = .Rows.Count 'GET SELLS GYO CC1 = .Columns.Count 'GET SELLS RETU End With Range(Cells(2, 1), Cells(RC1, CC1)).ClearContents 'OLD DATA(A2:??) CLEAR ' ' TEXT DATA ---> A EXCEL SHEETS Windows("A.TXT").Activate With Worksheets(1).Cells(2, 1).CurrentRegion 'DATA SELLS RC2 = .Rows.Count - 1 'GET SELLS GYO CC2 = .Columns.Count 'GET SELLS RETU End With '* Range("A1:J119").Select Range(Cells(1, 1), Cells(RC2, CC2)).Select 'COPY MOTO NO TEXT DATA SELECT Selection.Copy 'PASTE ' Windows(SaveBook.Name).Activate 'A.XLS Worksheets("A").Select Range("A1").Select 'HARITUKESAKI SELLS SELECT '** PASTE SPECIAL (KEISIKI HARITUKE) ** '** PASTE : VALUES Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ' OPEN TEXT FILE CLOSE Windows("A.TXT").Activate Application.DisplayAlerts = False 'NOT CONFIRM ActiveWorkbook.Close 'BOOK CLOSE ' Cells(1, 1).Select 'CORSORE SELLS A1 Application.ScreenUpdating = True 'SCRREN LOCK FREE DispStatMsg 0 'STATUS BAR MESSAGE CLEAR ' MsgBox "A SHEETS IS COMPLETED !!!" End Sub Sub UsdHyoCopy() Dim i, J As Integer Dim RC1, RC2 As Integer Dim CC1, CC2 As Integer MSG = "Copies Text File of USD to Excel Sheets (B) !!!" DispStatMsg 1, MSG 'STATUS BAR MESSAGE DISPLAY ' Windows("B.TXT").Activate With Worksheets(1).Cells(2, 2).CurrentRegion RC2 = .Rows.Count ' CC2 = .Columns.Count ' End With '* Range("B2:G9").Select Range(Cells(1, 1), Cells(RC2, CC2)).Select 'COPY MOTO Selection.Copy 'COPY ' Windows(SaveBook.Name).Activate 'SAMPLE.XLS Worksheets("B").Select Range("B9").Select 'OUTPUT SELLS SELECT '** PASTE SPECIAL (KEISIKI HARITUKE) ** '** PASTE : VALUES Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ' OPEN TEXT FILE CLOSE Windows("B.TXT").Activate Application.DisplayAlerts = False 'NOT CONFIRM ActiveWorkbook.Close 'BOOK CLOSE ' ' MOVE OF EFF-DATE & NO B9--> E6, C9-->E7 With Worksheets("B") .Range("E6").Value = .Range("B9").Value 'SET EFF.DATE .Range("E7").Value = .Range("C9").Value 'SET NUMBER .Range("E6").NumberFormat = "yyyy/mm/dd" .Range("B9:C9").ClearContents End With Range("E6:F7").Select With Selection .HorizontalAlignment = xlCenterAcrossSelection .VerticalAlignment = xlBottom .WrapText = False .Orientation = xlHorizontal .AddIndent = False End With ' Cells(1, 1).Select 'CURSOLE SELLS A1 Application.ScreenUpdating = True 'SCREEN LOCK FREE DispStatMsg 0 'STATUS BAR MESSAGE CLEAR ' MsgBox "B SHEETS IS COMPLETED !!!" End Sub Sub Create_Newbook() Dim SourceFileName As String Dim DestFileName As String Dim SavePath As String Dim SaveName As String Dim WorkName As String Dim SaveSheetIn As Integer Dim BookName As Object ' SavePath = ActiveWorkbook.Path Set BookName = Application.ActiveWorkbook '*------------------------* '* * '*------------------------* DestFileName = Application.GetSaveAsFilename("*.XLS", _ "RATE FILE(*.xls),*.xls", 1, "NEW EXCEL BOOK NAME") If DestFileName = "False" Then '<CANCEL> GoTo CopyCancel 'COPY STOP End If ' If Dir(DestFileName) = "" Then SaveSheetIn = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1 Workbooks.Add 'ADDED NEW BOOK Application.SheetsInNewWorkbook = SaveSheetIn ActiveWorkbook.SaveAs FileName:=DestFileName 'BOOK KARI SAVE ' ActiveWindow.Caption = Right(DestFileName, 10) DestFileName = ActiveWindow.Caption ' Else Workbooks.Open FileName:=DestFileName ' End If SaveName = ActiveWindow.Caption 'PASTE OUT BOOK NAME ' ' BOOK INFORMATION SET With ActiveWorkbook .Title = "AB" .Subject = "" .Author = "ISHIKAWA" .Keywords = "" .Comments = "" End With ' '*------------------------------* '* PASTE * '*------------------------------* MSG = "Saving ..." & SaveName DispStatMsg 1, MSG Application.ScreenUpdating = False 'SCREEN LOCK SET Windows(BookName.Name).Activate 'BOOKNAME:ESAMPLE.XLS ' Application.Worksheets("B").Copy _ before:=Workbooks(SaveName).Worksheets(1) ' Columns("B:G").Select ' Selection.ColumnWidth = 10 Range("A1").Select ' Windows(BookName.Name).Activate Application.Worksheets("A").Copy _ before:=Workbooks(SaveName).Worksheets(2) Application.DisplayAlerts = False Sheets(3).Delete Application.DisplayAlerts = True Windows(BookName.Name).Activate ActiveWorkbook.Close False ' ActiveWorkbook.Save ' ActiveWorkbook.Close DispStatMsg 0 Application.ScreenUpdating = True MsgBox "EXCEL SHEETS OF B AND A IS COMPLETED !!!" Exit Sub ' '*--------------* '* COPY STOP * '*--------------* CopyCancel: Beep MsgBox "NEW EXCEL BOOK SAVING CANCEL !!!", vbCritical, "SAVE" ActiveWorkbook.Close False Exit Sub End Sub '*Sub ModuleErase() '* Sheets("Module1").Visible = False '*End Sub Sub DispStatMsg(DisplaySwitch As Integer, Optional MSG) Static STAT As Boolean With Application Select Case DisplaySwitch Case 1 STAT = .DisplayStatusBar ' .DisplayStatusBar = True ' .StatusBar = MSG ' Case 0 .StatusBar = False ' .DisplayStatusBar = STAT ' End Select End With End Sub |
| ISHIKAWA さん、こんばんわ。 >ＦＤ（Ａドライブ）にあるA.TXTとB.TXTをエクセルに読み込み、 >指定したエクセルファイルに書き込み、セーブして終了（エクセルファイルを閉じる）。 >という処理を行うために、下記のようなＶＢＡを組みました。 とりあえず、 ↓ はどこにあるのでしょうか？ > UsdTextRead |
| りん さん、すみません。 実は RATE→A USD→B なのです。 読んだ時にわかりやすくしようとして、修正が出来てないところが たくさんありかえってわかりにくくなってしまいました・・・。 ごめんなさい。 >ISHIKAWA さん、こんばんわ。 > > >>ＦＤ（Ａドライブ）にあるA.TXTとB.TXTをエクセルに読み込み、 >>指定したエクセルファイルに書き込み、セーブして終了（エクセルファイルを閉じる）。 >>という処理を行うために、下記のようなＶＢＡを組みました。 > > >とりあえず、 > > ↓ はどこにあるのでしょうか？ >> UsdTextRead |
| KUさん(ISHIKAWAさん？)、おはようございます。 コードを追いかけた結果。 >Sub Create_Newbook() > <<略>> '↓代入が間違えてるのか、正しいのかは知りませんが。 BookNameがThisWorkbook（マクロのブック）になっているので > Windows(BookName.Name).Activate '↓この時点でマクロ終了 > ActiveWorkbook.Close False '↓以下は実行されません。 >' ActiveWorkbook.Save >' ActiveWorkbook.Close > DispStatMsg 0 > Application.ScreenUpdating = True > MsgBox "EXCEL SHEETS OF B AND A IS COMPLETED !!!" > Exit Sub > ' あと、 Dim BookName As Workbook と宣言しておけば、 Windows(BookName.Name).Activate ActiveWorkbook.Close False ↓ BookName.Close False の１行ですみますよ。 ActiveWorkbookやActiveSheetを使うと、実行してみたら対象が違っていたということが多々あるので、特に複数のブックを扱うときは気をつけないといけません。 |
| りんさん おそくなってすみません。 無事出来ました！ ありがとうございました！ |