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

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

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

パスワード:


パスワード紛失

マッチング処理

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

なし マッチング処理

msg# 1
depth:
0
前の投稿 - 次の投稿 | 親投稿 - 子投稿なし | 投稿日時 2010-6-6 13:15
ゲスト    投稿数: 0
Private Sub CommandButton1_Click()

Call MATCH_CHECK("testA", 1, "0.xlsx", "B", "B", "C", "F", "G", 40, "")

End Sub

Private Sub CommandButton2_Click()

Call MATCH_CHECK("testB", 2, "1.xlsx", "B", "B", "C", "J", "K", 36, "")

End Sub

Private Sub CommandButton3_Click()

Call MATCH_CHECK("test3", 3, "2.xlsx", "C", "B", "C", "N", "O", 4, "")

End Sub

Private Sub CommandButton4_Click()

Call MATCH_CHECK("test4", 4, "5.xlsx", "C", "B", "C", "S", "T", 28, "")

End Sub

'---------------------------------------------------------

'パラメータ一覧
'?環境名
'?フラグ
'?抽出ファイル名
'?抽出範囲
'?比較元1列目
'?比較元2列目
'?比較先1列目
'?比較先2列目
'?比較色
'?環境名

Sub MATCH_CHECK(NAME As String, FLAG As Integer, FILE As String, COLUMN As String, START_COLUMN As String, SECOND_COLUMN As String, THIRD_COLUMN As String, FOUR_COLUMN As String, CELL_COLOR2 As Integer, K_NAME As String)

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

'フォルダ変数宣言
Dim FOLDER As String

'シート変数宣言
Dim SH1 As String
Dim SH2 As String

'ファイル変数宣言
Dim MAIN_FILE As String
Dim MAIN_FILENAME As String
Dim FILENAME As String

'メッセージ変数
'Dim APRI_NG_MSG As String
'Dim APRI_NG_TITLE As String
Dim DATE_NG_MSG As String
Dim DATE_NG_TITLE As String
Dim MATCH_OK_MSG As String
Dim MATCH_OK_TITLE As String
Dim MATCH_NG_MSG As String
Dim MATCH_NG_TITLE As String
Dim KANKYO_MSG As String
Dim KANKYO_OK_TITLE As String
Dim KANKYO_NG_TITLE As String

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

'カウント変数宣言
Dim i As Integer
Dim ii As Integer
Dim Shori_Gokei As Integer
Dim NO_COUNT_CELL As Integer

'その他変数設定
Dim CELL_COLOR1 As Integer
Dim START_CELL As String
Dim DATE_CELL As String
Dim RC As Long

'☆変数宣言終了--------------------------------------------------------------------------------------

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

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

'フォルダ変数設定
FOLDER = "D:\test"

'シート変数設定
SH1 = "1"
SH2 = "2"

'ファイル変数設定
MAIN_FILE = "マッチ.xls"
MAIN_FILENAME = MAIN_PATH & "\" & MAIN_FILE
FILENAME = FOLDER & "\" & FILE

'メッセージ変数設定
'APRI_NG_MSG = LEVEL_NAME & " 取込アプリケーションの起動に失敗しました。"
'APRI_NG_TITLE = LEVEL_NAME & " 取込アプリケーション未起動通知"
DATE_NG_MSG = LEVEL_NAME & " 取込ファイルが正常に更新されておりません。"
DATE_NG_TITLE = LEVEL_NAME & " 取込ファイル 異常通知"
MATCH_OK_MSG = LEVEL_NAME & " の移行作業は正常に完了しています。" & vbCrLf & _
"後続処理をお願いします。"
MATCH_OK_TITLE = LEVEL_NAME & " 移行作業結果 正常通知"
MATCH_NG_MSG = LEVEL_NAME & " の移行作業に移行洩れが発生しております。"
MATCH_NG_TITLE = LEVEL_NAME & " 移行作業結果 異常通知"
KANKYO_MSG = ""
KANKYO_OK_TITLE = LEVEL_NAME & " 環境チェック結果 正常通知"
KANKYO_NG_TITLE = LEVEL_NAME & " 環境チェック結果 異常通知"

'オブジェクト変数設定
Set START_CELL = Range("B8")
Set CLEAR_CELL = Range("B8:C65536")

'カウント変数設定
NO_COUNT_CELL = 7

'その他変数設定
CELL_COLOR1 = -4142
PROMO_START_CELL = Range("A2").Address
PROMO_DATE_CELL = Range("D2").Address

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

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

Application.ScreenUpdating = False

'初期化
CLEAR_CELL.Interior.ColorIndex = CELL_COLOR1

'アプリケーション起動処理
'RC = Shell("notepad.exe", vbNormalFocus)
'
'If RC = 0 Then
' MsgBox APRI_NG_MSG, vbOKOnly, APRI_NG_TITLE
'End If

'ファイル取込処理
Workbooks.Open (FILENAME)
Workbooks(FILE).Activate
Worksheets(SH2).Select

If Format(Range(PROMO_DATE_CELL).Value, "yyyy/mm/dd") <> Format(Date) Then
MsgBox DATE_NG_MSG, vbOKOnly, DATE_NG_TITLE
Workbooks(PROMO_FILE).Close
GoTo MATCH_END:
End If

PROMO_END_CELL = Range(PROMO_START_CELL).End(xlDown).Row
Range(Range(PROMO_START_CELL), Cells(PROMO_END_CELL, PROMO_COLUMN)).Copy
Workbooks(PROMO_FILE).Close
Workbooks(MAIN_FILE).Activate
Cells(1 + NO_COUNT_CELL, THIRD_COLUMN).Select
ActiveSheet.Paste

'色付け処理
START_CELL.Select
Shori_Gokei = ActiveCell.End(xlDown).Row - NO_COUNT_CELL
Range(Cells(1 + NO_COUNT_CELL, THIRD_COLUMN), Cells(Shori_Gokei + NO_COUNT_CELL, FOUR_COLUMN)).Interior.ColorIndex = CELL_COLOR1

If FLAG = 1 Then
START_CELL.Select
TRIM_CNT = ActiveCell.End(xlDown).Row
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(TRIM_CNT, ActiveCell.Offset(0, 1).Column)).Select
For Each TRIM_CELL In Selection
TRIM_CELL.Value = Replace(TRIM_CELL.Value, " ", "")
TRIM_CELL.Value = Replace(TRIM_CELL.Value, " ", "")
START_CELL.Select
Next
End If

Application.ScreenUpdating = True

For i = 1 To Shori_Gokei
For ii = 1 To Shori_Gokei
If Cells(i + NO_COUNT_CELL, START_COLUMN) = Cells(ii + NO_COUNT_CELL, THIRD_COLUMN) And _
Cells(i + NO_COUNT_CELL, SECOND_COLUMN) = Cells(ii + NO_COUNT_CELL, FOUR_COLUMN) Then
Range(Cells(i + NO_COUNT_CELL, START_COLUMN), Cells(i + NO_COUNT_CELL, SECOND_COLUMN)).Interior.ColorIndex = CELL_COLOR2
Range(Cells(ii + NO_COUNT_CELL, THIRD_COLUMN), Cells(ii + NO_COUNT_CELL, FOUR_COLUMN)).Interior.ColorIndex = CELL_COLOR2
End If
Next ii
Next i

Application.ScreenUpdating = False

'移行判定処理
If Range(Cells(1 + NO_COUNT_CELL, START_COLUMN), Cells(Shori_Gokei + NO_COUNT_CELL, SECOND_COLUMN)).Interior.ColorIndex = CELL_COLOR2 And _
Range(Cells(1 + NO_COUNT_CELL, THIRD_COLUMN), Cells(Shori_Gokei + NO_COUNT_CELL, FOUR_COLUMN)).Interior.ColorIndex = CELL_COLOR2 Then
'環境名移行判定処理
If FLAG > 2 Then
Cells(1 + NO_COUNT_CELL, FOUR_COLUMN).Offset(0, 1).Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value <> KANKYO_NAME Then
KANKYO_MSG = KANKYO_MSG & vbCrLf & ActiveCell.Offset(0, -2).Value & "  /  " & _
ActiveCell.Offset(0, -1).Value & "  /  " & ActiveCell.Value
End If
ActiveCell.Offset(1, 0).Select
Loop
If Len(KANKYO_MSG) > 0 Then
KANKYO_MSG = "名前は正常に移行しましたが、環境名が" & KANKYO_NAME & "環境にすべて移行されていません。" & _
"移行出来なかった対象を下記に表示します。" & vbCrLf & vbCrLf & _
"名  /  名  /  環境名" & vbCrLf & KANKYO_MSG
MsgBox KANKYO_MSG, vbOKOnly, KANKYO_NG_TITLE
GoTo MATCH_END:
End If
Else
End If
MsgBox MATCH_OK_MSG, vbOKOnly, MATCH_OK_TITLE
Else
MsgBox MATCH_NG_MSG, vbOKOnly, MATCH_NG_TITLE
End If

MATCH_END:

Application.ScreenUpdating = True

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

End Sub

これを簡略化出来ないだろうか?
投票数:70 平均点:5.00
返信する

この投稿に返信する

題名
ゲスト名   :
投稿本文

投稿ツリー

  条件検索へ


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