エクセル(Excel)&ワード(Word)質問掲示板

より見やすく使いやすいエクセル掲示板を目指し、新たにエクセルの質問掲示板を開設いたしました。 これに伴い、当サイトでは今後、新規投稿はできなくなります。(閲覧は当面可能です。)
今後は新掲示板をご利用いただきますよう宜しくお願い致します。今後ともよろしくお願い致します。
○新掲示板
エクセル(Excel)解決掲示板

エクセル・ワードの基本操作に関する質問や関数やマクロの使い方などエクセルとワードに関する質問掲示板。
Welcome Guest 
メインメニュー
ログイン
ユーザー名:

パスワード:


パスワード紛失

マクロ 18奥義

このトピックの投稿一覧へ

なし マクロ 18奥義

msg# 1
depth:
0
前の投稿 - 次の投稿 | 親投稿 - 子投稿なし | 投稿日時 2010-1-24 17:30
ゲスト    投稿数: 0
Sub 当日月次シート取込処理()

'☆変数宣言開始--------------------------------------------------------------------------------------------------------------------------

'値変数宣言
Dim i As Integer
Dim CNT As Integer
Dim First_Column As Integer
Dim Second_Column As Integer
Dim SECOND_CNT As Integer
Dim Minimum_Value As Integer
Dim Maximum_Value As Integer
Dim Half_Vlue As Integer
Dim FREE_NUMBER As Integer

'パス変数宣言
Dim MAIN_PATH As String

'フォルダ変数宣言
Dim BKUP_FOLDER As String
Dim YEAR_FOLDER As String
Dim MONTHLY_FOLDER As String

'シート変数宣言
Dim T_SH As String

'ファイル変数宣言
Dim MAIN_FILE As String
Dim T_TXT As String
Dim Filename As String

'メッセージ変数宣言
Dim NO_FILE_MSG As String
Dim NO_FILE_TITLE As String
Dim FILE_COUNTOVER_MSG As String
Dim FILE_COUNTOVER_TITLE As String
Dim END_MSG As String
Dim END_TITLE As String

'オブジェクト変数宣言
Dim FSO As Object
Dim START_CELL As Object

'配列変数宣言
Dim MONTHLY_NAME() As String

'☆変数宣言開始--------------------------------------------------------------------------------------------------------------------------

'☆変数設定開始--------------------------------------------------------------------------------------------------------------------------

'値変数設定
Minimum_Value = 1
Maximum_Value = 18
Half_Vlue = Maximum_Value / 2

'日付変数設定
YYYY = CStr(Format(Date, "yyyy"))
MM = CStr(Format(Date, "mm"))
DD = CStr(Format(Date, "dd"))
YMD = YYYY & MM & DD

'パス変数設定
MAIN_PATH = ThisWorkbook.Path

'フォルダ変数設定
BKUP_FOLDER = MAIN_PATH + "\" & "txt_bkup"
YEAR_FOLDER = BKUP_FOLDER + "\" & YYYY
MONTHLY_FOLDER = YEAR_FOLDER + "\" & MM

'シート変数設定
T_SH = "当日分"

'ファイル変数設定
MAIN_FILE = "test.xls"
T_TXT = YMD & ".txt"
Filename = MAIN_PATH & "\" & T_TXT

'メッセージ変数設定
NO_FILE_MSG = T_TXT & "が見つかりません。至急担当者に確認して下さい!"
NO_FILE_TITLE = "当日取込ファイル未存在メッセージ"
FILE_COUNTOVER_MSG = T_TXT & "内の月次数が報記載枠より多い為、すべての次数を取得出来ません。至急担当者に確認して下さい!"
FILE_COUNTOVER_TITLE = "当日取込ファイル上限数超メッセージ"
END_MSG = "正常に月次名を取り込めました。"
END_TITLE = "正常取込処理メッセージ"

'オブジェクト変数設定
Set FSO = CreateObject("Scripting.FileSystemObject")
Set START_CELL = Range("BQ32")

'配列変数設定
ReDim MONTHLY_NAME(Minimum_Value To Maximum_Value)

'☆変数設定終了--------------------------------------------------------------------------------------------------------------------------

'☆処理開始--------------------------------------------------------------------------------------------------------------------------

'ファイル存在チェック処理
If FSO.FileExists(Filename) = False Then
MsgBox NO_FILE_MSG, _
vbExclamation, NO_FILE_TITLE
Workbooks(MAIN_FILE).Activate
Sheets(T_SH).Select
Cells(1, 1).Select
Set FSO = Nothing
Exit Sub
End If

'当日分テキストファイル配列取込処理
CNT = 0
i = 1
FREE_NUMBER = FreeFile

Open Filename For Input As #FREE_NUMBER
Do Until EOF(FREE_NUMBER)
Line Input #FREE_NUMBER, TMP
CNT = CNT + 1
If i > 18 Then
MsgBox FILE_COUNTOVER_MSG, _
vbExclamation, FILE_COUNTOVER_TITLE
Workbooks(MAIN_FILE).Activate
Sheets(T_SH).Select
Cells(1, 1).Select
Set FSO = Nothing
Exit Sub
End If
MONTHLY_NAME(i) = TMP
i = i + 1
Loop

Close #FREE_NUMBER

'本日の次作業名貼り付け処理
Workbooks(MAIN_FILE).Activate



Range("BQ32:DC49").Select
Selection.ClearContents

START_CELL.Select

If CNT > Half_Vlue Then
For First_Column = Minimum_Value To Half_Vlue
ActiveCell.Value = MONTHLY_NAME(First_Column)
ActiveCell.VerticalAlignment = xlCenter
ActiveCell.Offset(1, 0).Select
Next
START_CELL.Offset(0, 1).Select
SECOND_CNT = CNT - Half_Vlue
For Second_Column = 1 To SECOND_CNT
ActiveCell.Value = MONTHLY_NAME(Second_Column + Half_Vlue)
ActiveCell.VerticalAlignment = xlCenter
ActiveCell.Offset(1, 0).Select
Next
Else
For First_Column = Minimum_Value To CNT
ActiveCell.Value = MONTHLY_NAME(First_Column)
ActiveCell.VerticalAlignment = xlCenter
ActiveCell.Offset(1, 0).Select
Next
End If

START_CELL.Select

'本日分テキストファイルBKUPフォルダ存在確認及び、作成処理
If FSO.FolderExists(BKUP_FOLDER) Then
Else
MkDir BKUP_FOLDER
End If

If FSO.FolderExists(YEAR_FOLDER) Then
Else
MkDir YEAR_FOLDER
End If

If FSO.FolderExists(MONTHLY_FOLDER) Then
Else
MkDir MONTHLY_FOLDER
End If

'本日分テキストファイルBKUPフォルダ移動処理
FSO.MoveFile Filename, MONTHLY_FOLDER + "\" & T_TXT

Set FSO = Nothing

'正常メッセージ表示処理
MsgBox END_MSG, _
vbinfomation, END_TITLE

Workbooks(MAIN_FILE).Activate
Sheets(T_SH).Select
Cells(1, 1).Select

'☆処理終了--------------------------------------------------------------------------------------------------------------------------

End Sub


この処理をもうすこし効率良く書けるにはどうすればよいのでしょうか?
投票数:88 平均点:4.43
返信する

この投稿に返信する

題名
ゲスト名   :
投稿本文

投稿ツリー

  条件検索へ


スポンサーリンク
スポンサーリンク
エクセル・ワード質問/回答集 - クイズ・問題QUUS! - 無料英語学習 - 投資家・トレーダー掲示版
為替(FX)テクニカル分析入門 - エクセル(EXCEL)学習・入門 - Word(ワード)の使い方/活用・入門
Copy right(c) 2006-2010 エクセル&ワード質問掲示板 all right reserved