Excel TEST_リボン
作成中
紐づけ用マクロ
フォーム名：F01_vlook
Option Explicit
'セル名前
''書き込み
' 'ファイル名
' WRITE_FILE
' 'シート名
' WRITE_SHEET
' '開始行
' WRITE_START
' 'keyの列
' write_key
' 'keyが何列目にあるか
' WRITE_KEY_NO
' '対象列項目名
' WRITE_NAME
' '対象項目が何列目にあるか
' WRITE_NAME_NO
' '最終列以降の項目
' WRITE_END_NAME
'
''読み込み
' 'ファイル名
' READ_FILE
' 'シート名
' READ_SHEET
' '開始行
' READ_START
' 'keyの列
' read_key
' 'keyが何列目にあるか
' READ_KEY_NO
' '対象列項目名
' READ_NAME
' '対象項目が何列目にあるか
' READ_NAME_NO
'使用するObject名
'書き込み先
'ファイル名
'write_filename
'シート名
'write_sheetname
'keyの列
'write_key
'書き込み対象項目名
'write_colname
'最終列以降（右端に出力）の項目名
'write_column_addname
'開始行
'write_start_row
'keyが何列目にあるか
'write_key_col
'書き込み対象項目何列目にあるか
'write_colnum
'
'
'
'読み込み先
'
'ファイル名
'read_filename
'シート名
'read_sheetname
'keyの列
'read_key
'読み込み対象項目名
'read_colname
'開始行
'read_start_row
'keyが何列目にあるか
'read_key_col
'読み込み対象項目何列目にあるか
'read_colnum
'
'
'
'紐づかない場合反映値
'write_not_associated
'完全一致
'write_perfect_match
'上書き実行
'write_overwriting_execution
'
'
'実行
'cmd_execute
'
Private Sub UserForm_Initialize()
'開いてるブックの一覧 書き込み、読み込み共通
Dim book_list As Variant
Dim v As Variant
'keyの列
Me.write_key_col.Text = 1
Me.read_key_col.Text = 1
'値がない場合の反映値
Me.write_not_associated.Text = ""
'ファイル一覧
book_list = open_book_list
For Each v In book_list
Me.write_filename.AddItem v
Me.read_filename.AddItem v
Next
'Me.write_filename.ListIndex = 0
'Me.read_filename.ListIndex = 0
''入力値を復元
With ThisWorkbook.Sheets("config")
'書き込み
'ファイル名
If .Range("WRITE_FILE").Value = "" Then
'デフォルトで表示させる値
Me.write_filename.Text = ActiveWorkbook.Name
Else
'ファイルを開いてるか
If workbooks_open_check(.Range("WRITE_FILE").Value) Then
Me.write_filename.Text = .Range("WRITE_FILE").Value
Else
'開いて無ければ初期化
Call cmd_INIT_Click
End If
End If
'対象列項目名
Me.write_column_addname.Text = .Range("WRITE_END_NAME").Value
'読み込み
'ファイル名
If .Range("READ_FILE").Value = "" Then
Me.read_filename.Text = ActiveWorkbook.Name
Else
If workbooks_open_check(.Range("READ_FILE").Value) Then
Me.write_filename.Text = .Range("READ_FILE").Value
Else
'開いて無ければ初期化
Call cmd_INIT_Click
End If
End If
End With
End Sub
Private Sub cmd_END_Click()
Unload Me
End Sub
Private Sub cmd_execute_Click()
Dim result() As String
Dim org_datalist() As String
Dim result_not_overwriting() As String
Dim output_range As Range
Dim v As Variant
Dim i As Long
Dim rc As Integer
Dim max_row_key As Long
Dim max_row_ref As Long
Dim max_col_key As Long
Dim max_col_ref As Long
Dim cnt As Long
rc = MsgBox("実行しますか？", vbYesNo + vbQuestion, "確認")
If rc = vbNo Then
Exit Sub
End If
'上書きチェック アラート 元データの項目名を指定でチェックが入ってる場合
If write_column_addname.Enabled = False Then
If Me.write_overwriting_execution.Value = True Then
rc = MsgBox("上書きされますがよろしいですか？", vbYesNo + vbQuestion, "確認")
If rc = vbNo Then
Exit Sub
End If
End If
End If
'どれか空白があったらエラーを表示
'書き込み
If Me.write_filename.Text = "" Then
MsgBox "書き込み ファイル名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_sheetname.Text = "" Then
MsgBox "書き込み シート名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_key.Text = "" Then
MsgBox "書き込み keyの列が入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_key_col.Text = "" Then
MsgBox "書き込み keyが何列目にあるかが入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_colname.Text = "" Then
MsgBox "書き込み 対象列項目名を取得するための列が入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_colnum.Text = "" Then
MsgBox "書き込み 対象項目が何列目にあるかが入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_column_addname.Text = "" Then
MsgBox "書き込み 最終列以降の項目が入力されてません", vbExclamation
Exit Sub
'読み込み
ElseIf Me.read_filename.Text = "" Then
MsgBox "読み込み ファイル名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.read_sheetname.Text = "" Then
MsgBox "読み込み シート名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.read_start_row.Text = "" Then
MsgBox "読み込み 開始行が入力されてません", vbExclamation
Exit Sub
ElseIf Me.read_key.Text = "" Then
MsgBox "読み込み keyの列が入力されてません", vbExclamation
Exit Sub
ElseIf Me.read_key_col.Text = "" Then
MsgBox "読み込み keyが何列目にあるかが入力されてません", vbExclamation
Exit Sub
ElseIf Me.read_colname.Text = "" Then
MsgBox "読み込み 対象列項目名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.read_colnum.Text = "" Then
MsgBox "読み込み 対象項目が何列目にあるかが入力されてません", vbExclamation
Exit Sub
End If
'入力値をバックアップ
With ThisWorkbook.Sheets("config")
'書き込み
'ファイル名
.Range("WRITE_FILE").Value = Me.write_filename.Text
'シート名
.Range("WRITE_SHEET").Value = Me.write_sheetname.Text
'開始行
.Range("WRITE_START").Value = Me.write_start_row.Text
'keyの列
.Range("WRITE_KEY").Value = Me.write_key.Text
'keyが何列目にあるか
.Range("WRITE_KEY_NO").Value = Me.write_key_col.Text
'対象列項目名
.Range("WRITE_NAME").Value = Me.write_colname.Text
'対象項目が何列目にあるか
.Range("WRITE_NAME_NO").Value = Me.write_colnum.Text
'最終列以降の項目
.Range("WRITE_END_NAME").Value = Me.write_column_addname.Text
'読み込み
'ファイル名
.Range("READ_FILE").Value = Me.read_filename.Text
'シート名
.Range("READ_SHEET").Value = Me.read_sheetname.Text
'開始行
.Range("READ_START").Value = Me.read_start_row.Text
'keyの列
.Range("READ_KEY").Value = Me.read_key.Text
'keyが何列目にあるか
.Range("READ_KEY_NO").Value = Me.read_key_col.Text
'対象列項目名
.Range("READ_NAME").Value = Me.read_colname.Text
'対象項目が何列目にあるか
.Range("READ_NAME_NO").Value = Me.read_colnum.Text
'値がない場合の反映値
.Range("P_NOT_ASSOCIATED").Value = Me.write_not_associated.Text
not_associated = Me.write_not_associated.Text
End With
'ブック
Set write_wb = Workbooks(Me.write_filename.Text)
Set read_wb = Workbooks(Me.read_filename.Text)
'シート名
Set write_sh = write_wb.Worksheets(Me.write_sheetname.Text)
Set read_sh = read_wb.Worksheets(Me.read_sheetname.Text)
'開始行
w_start_row = Me.write_start_row.Text
ref_start_row = Me.read_start_row.Text
'keyの列
w_key_col = Me.write_key_col.Text
ref_key_col = Me.read_key_col.Text
'書き込み対象列項目名
w_colname = Me.write_colname.Text
'読み込み対象列項目名
ref_colname = Me.read_colname.Text
'書き込み項目番号
w_colnum = Me.write_colnum.Text
'読み込み項目番号
ref_colnum = Me.read_colnum.Text
'最終行
max_row_key = getMaxRow(write_sh, w_key_col)
max_row_ref = getMaxRow(read_sh, ref_key_col)
'最終列
max_col_key = getMaxCol(write_sh, w_start_row - 1)
max_col_ref = getMaxCol(read_sh, ref_start_row - 1)
'status
status_lb = "データ取得中・・・"
DoEvents
Set output_range = write_sh.Range(write_sh.Cells(w_start_row, w_colnum), write_sh.Cells(max_row_key, w_colnum))
If Me.write_colname.Text = "最終列以降（右端に出力）" Then
write_sh.Cells(w_start_row - 1, Int(Me.write_colnum.Text)).Value = Me.write_column_addname.Text
End If
' pd_merge(検索値（範囲）, 検索範囲, 列番号（取得したい列）, 出力範囲)
If pd_merge_addin(write_sh.Range(write_sh.Cells(w_start_row, w_key_col), write_sh.Cells(max_row_key, w_key_col)), _
read_sh.Range(read_sh.Cells(ref_start_row, 1), read_sh.Cells(max_row_ref, max_col_ref)), _
ref_colnum, _
output_range, _
result) Then
End If
'上書きにチェックが入ってるか
If Me.write_overwriting_execution.Value = True Then
'上書きする
output_range.Value = result
Else
'上書きしない
'元データを配列に格納
cnt = output_range.Rows.Count
ReDim org_datalist(1 To cnt, 1 To 1)
i = 1
For Each v In output_range
org_datalist(i, 1) = v
i = i + 1
Next
'機能：上書きするかしないか 配列を加工する
Call arrmake_overwriting_addin(org_datalist, result)
output_range.Value = org_datalist
End If
'status
Me.status_lb = "処理完了"
MsgBox "完了！", vbInformation
End Sub
Private Sub cmd_INIT_Click()
'入力値をバックアップ
With ThisWorkbook.Sheets("config")
'書き込み
'ファイル名
.Range("WRITE_FILE").Value = ""
'シート名
.Range("WRITE_SHEET").Value = ""
'開始行
.Range("WRITE_START").Value = 2
'keyの列
.Range("WRITE_KEY").Value = ""
'keyが何列目にあるか
.Range("WRITE_KEY_NO").Value = ""
'対象列項目名
.Range("WRITE_NAME").Value = ""
'対象項目が何列目にあるか
.Range("WRITE_NAME_NO").Value = ""
'最終列以降の項目
.Range("WRITE_END_NAME").Value = "Vlook取得"
'読み込み
'ファイル名
.Range("READ_FILE").Value = ""
'シート名
.Range("READ_SHEET").Value = ""
'開始行
.Range("READ_START").Value = 2
'keyの列
.Range("READ_KEY").Value = ""
'keyが何列目にあるか
.Range("READ_KEY_NO").Value = ""
'対象列項目名
.Range("READ_NAME").Value = ""
'対象項目が何列目にあるか
.Range("READ_NAME_NO").Value = ""
End With
Call vlook_addin_Init
End Sub
'------------------------------------------------------------------
'書き込み先設定
'------------------------------------------------------------------
'書き込み先 ファイル名
Private Sub write_filename_Change()
'ブックが変更されたら書き込み先シート名を反映
Dim sheet_list As Variant
sheet_list = book_sheets_list(Workbooks(Me.write_filename.Value))
'シートの一覧
Dim v As Variant
Me.write_sheetname.Clear
For Each v In sheet_list
Me.write_sheetname.AddItem v
Next
'デフォルトで表示させる値
' Me.write_sheetname.ListIndex = 0
With ThisWorkbook.Sheets("config")
'シートがあるか
If sheets_exists(Workbooks(Me.write_filename.Value), .Range("WRITE_SHEET").Value) Then
Me.write_sheetname.Text = .Range("WRITE_SHEET").Value
Else
'シートがない場合
Me.write_sheetname.Text = Workbooks(Me.write_filename.Value).Sheets(1).Name
End If
End With
'シートがない場合
If Me.write_sheetname.Text = "" Then
Me.write_sheetname.Text = Workbooks(Me.write_filename.Value).Sheets(1).Name
End If
End Sub
'書き込み先 シート名
Private Sub write_sheetname_Change()
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
'シートが変更されたら
'シートが未設定のとき
If Me.write_sheetname.Text = "" Then
Me.write_sheetname.Text = Workbooks(Me.write_filename.Value).Sheets(1).Name
End If
'開始行設定デフォルト
Me.write_start_row.Text = ThisWorkbook.Sheets("config").Range("WRITE_START").Value
Call write_start_row_Change
End Sub
'開始行
Private Sub write_start_row_Change()
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
If Me.write_start_row.Value = "" Then
Exit Sub
End If
'最終列
max_col = getMaxCol(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1, max_col)
'key
Me.write_key.Clear
For Each v In col_list
Me.write_key.AddItem v
Next
'デフォルトで表示させる値
Me.write_key.ListIndex = 0
'書き込み対象列項目名
Me.write_colname.Clear
For Each v In col_list
'keyは項目に入れない
If Not Me.write_key.Text = v Then
Me.write_colname.AddItem v
End If
Next
Me.write_colname.AddItem "最終列以降（右端に出力）"
With ThisWorkbook.Sheets("config")
'書き込み
'最終列以降の項目
Me.write_column_addname.Text = .Range("WRITE_END_NAME").Value
End With
'configに値がなければ、"最終列以降（右端に出力）"を表示
If Me.write_colname.Text = "" Then
Me.write_colname.Text = "最終列以降（右端に出力）"
End If
End Sub
'書き込み先 キーの列
Private Sub write_key_Change()
'項目名が変更されたら書き込み先の項目番号を反映
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
Dim i As String
'最終列
max_col = getMaxCol(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1, max_col)
Me.write_key_col.Text = ""
i = 0
For Each v In col_list
i = i + 1
If v = Me.write_key.Text Then
Exit For
End If
Next
Me.write_key_col.Text = i
End Sub
'書き込み先 書き込み対象列項目名
Private Sub write_colname_Change()
'項目名が変更されたら書き込み先の項目番号を反映
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
Dim i As String
'最終列
max_col = getMaxCol(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1, max_col)
Me.write_colnum.Text = ""
i = 0
For Each v In col_list
i = i + 1
If v = Me.write_colname.Text Then
Exit For
End If
Next
If Me.write_colname.Text = "最終列以降（右端に出力）" Then
i = i + 1
write_column_addname.Enabled = True
Else
write_column_addname.Enabled = False
End If
Me.write_colnum.Text = i
End Sub
'------------------------------------------------------------------
'読み込み先設定
'------------------------------------------------------------------
'読み込み先 ファイル名
Private Sub read_filename_Change()
'ブックが変更されたら書き込み先シート名を反映
Dim sheet_list As Variant
sheet_list = book_sheets_list(Workbooks(Me.read_filename.Value))
Dim v As Variant
Me.read_sheetname.Clear
For Each v In sheet_list
Me.read_sheetname.AddItem v
Next
'デフォルトで表示させる値
' Me.read_sheetname.ListIndex = 0
With ThisWorkbook.Sheets("config")
'シートがあるか
If sheets_exists(Workbooks(Me.read_filename.Value), .Range("READ_SHEET").Value) Then
Me.read_sheetname.Text = .Range("READ_SHEET").Value
End If
End With
'アクティブシート名
If Me.read_sheetname.Text = "" Then
Me.read_sheetname.Text = Workbooks(Me.read_filename.Value).Sheets(1).Name
End If
End Sub
'読み込み先 シート名
Private Sub read_sheetname_Change()
'シートが変更されたら
'シートが未設定のとき
If Me.read_sheetname.Text = "" Then
Me.read_sheetname.Text = Workbooks(Me.read_filename.Value).Sheets(1).Name
End If
'開始行設定デフォルト
Me.read_start_row.Text = ThisWorkbook.Sheets("config").Range("READ_START").Value
Call read_start_row_Change
End Sub
'開始行
Private Sub read_start_row_Change()
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
If Me.read_start_row.Value = "" Then
Exit Sub
End If
On Error GoTo ErrHandler
'最終列
max_col = getMaxCol(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1, max_col)
'key
Me.read_key.Clear
For Each v In col_list
Me.read_key.AddItem v
Next
'デフォルトで表示させる値
Me.read_key.ListIndex = 0
'書き込み対象列項目名
Me.read_colname.Clear
For Each v In col_list
Me.read_colname.AddItem v
Next
'デフォルトで表示させる値
' Me.read_colname.ListIndex = 0
With ThisWorkbook.Sheets("config")
'読み込み
'開始行
' Me.read_start_row.Text = .Range("READ_START").Value
End With
ErrHandler:
End Sub
'読み込み先 キーの列
Private Sub read_key_Change()
'キーの列が変更されたら書き込み先の項目番号を反映
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
Dim i As String
'最終列
max_col = getMaxCol(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1, max_col)
Me.read_key_col.Text = ""
i = 1
For Each v In col_list
If v = Me.read_key.Text Then
Exit For
End If
i = i + 1
Next
Me.read_key_col.Text = i
End Sub
'読み込み先 読み込み対象列項目名
Private Sub read_colname_Change()
'読み込み対象列項目名が変更されたら書き込み先の項目番号を反映
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
Dim i As String
'最終列
max_col = getMaxCol(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1, max_col)
Me.read_colnum.Text = ""
i = 1
For Each v In col_list
If v = Me.read_colname.Text Then
Exit For
End If
i = i + 1
Next
Me.read_colnum.Text = i
End Sub
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
文字列結合
フォーム名：F02_string_join
Option Explicit
' 'ファイル名
' STR_FILE
' 'シート名
' STR_SHEET
' '開始行
' STR_START
' '結合文字
' STR_JOIN
' '最終列を取得する列
' STR_KEY_COL
' '結合対象列項目列 （例：1+2+3）
' STR_JOIN_NO
' '書き込み対象列項目名
' STR_COLNAME
' '対象項目名が何列目にあるか
' STR_COL_NO
' '最終列以降（右端に出力）の項目名
' STR_COLADD
'使用するObject名
'
'ファイル名
'filename
'シート名
'sheetname
'開始行
'start_row
'結合文字
'join_str
'結合対象列項目何列目にあるか （例：1+2+3）
'join_num
'書き込み対象列項目名
'colname
'最終列以降（右端に出力）を選択した場合は項目名を指定する
'column_addname
'最終行を取得するの列 (何列目にあるか)
'key_col
'対象項目名何列目にあるか
'colnum
'
'
'実行
'cmd_execute
Private Sub cmd_END_Click()
Unload Me
End Sub
Private Sub cmd_INIT_Click()
With ThisWorkbook.Sheets("config")
'ファイル名
.Range("STR_FILE").Value = ""
'シート名
.Range("STR_SHEET").Value = ""
'開始行
.Range("STR_START").Value = 2
'結合文字
.Range("STR_JOIN").Value = "_"
'最終列を取得する列
.Range("STR_KEY_COL").Value = 1
'結合対象列項目列 （例：1+2+3）
.Range("STR_JOIN_NO").Value = "1+2+3"
'書き込み対象列項目名
.Range("STR_COLNAME").Value = ""
'対象項目名が何列目にあるか
.Range("STR_COL_NO").Value = ""
'最終列以降（右端に出力）の項目名
.Range("STR_COLADD").Value = "結合文字列"
End With
Call string_join_addin_Init
End Sub
Private Sub UserForm_Initialize()
Dim book_list As Variant
Dim v As Variant
'開始行
'Me.start_row.Text = 2
'結合文字
Me.join_str.Text = "_"
'対象項目列
Me.join_num.Text = "1+2+3"
'最終行をカウントする列
Me.key_col.Text = 1
'ファイル名
book_list = open_book_list
For Each v In book_list
Me.filename.AddItem v
Next
''入力値を復元
With ThisWorkbook.Sheets("config")
' 'ファイル名
' If .Range("STR_FILE").Value = "" Then
' 'デフォルトで表示させる値 アクティブブック名表示
'' Me.filename.ListIndex = 0
' Me.filename.Text = ActiveWorkbook.Name
' Else
' Me.filename.Text = .Range("STR_FILE").Value
' End If
'書き込み
'ファイル名
If .Range("STR_FILE").Value = "" Then
'デフォルトで表示させる値
Me.filename.Text = ActiveWorkbook.Name
Else
'ファイルを開いてるか
If workbooks_open_check(.Range("STR_FILE").Value) Then
Me.filename.Text = .Range("STR_FILE").Value
Else
'開いて無ければ初期化
Call cmd_INIT_Click
End If
End If
'開始行
' Me.start_row.Text = .Range("STR_START").Value
'結合文字
Me.join_str.Text = .Range("STR_JOIN").Value
'最終列を取得する列
Me.key_col.Text = .Range("STR_KEY_COL").Value
'結合対象列項目列 （例：1+2+3）
Me.join_num.Text = .Range("STR_JOIN_NO").Value
'最終列以降（右端に出力）の項目名
Me.column_addname.Text = .Range("STR_COLADD").Value
End With
End Sub
'実行
Private Sub cmd_execute_Click()
Dim rc As Integer
rc = MsgBox("実行しますか？", vbYesNo + vbQuestion, "確認")
If rc = vbNo Then
Exit Sub
End If
'どれか空白があったらエラーを表示
If Me.filename.Text = "" Then
MsgBox "ファイル名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.sheetname.Text = "" Then
MsgBox "シート名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.start_row.Text = "" Then
MsgBox "開始行が入力されてません", vbExclamation
Exit Sub
ElseIf Me.join_str.Text = "" Then
MsgBox "結合文字が入力されてません", vbExclamation
Exit Sub
ElseIf Me.key_col.Text = "" Then
MsgBox "最終行を取得するための列が入力されてません", vbExclamation
Exit Sub
ElseIf Me.join_num.Text = "" Then
MsgBox "結合対象列項目列 （例：1+2+3）が入力されてません", vbExclamation
Exit Sub
ElseIf Me.colname.Text = "" Then
MsgBox "書き込み対象列項目名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.colnum.Text = "" Then
MsgBox "対象項目名が何列目にあるかが入力されてません", vbExclamation
Exit Sub
ElseIf Me.column_addname.Text = "" Then
MsgBox "最終列以降（右端に出力）を選択した場合が入力されてません", vbExclamation
Exit Sub
End If
'ブック
Set write_wb = Workbooks(Me.filename.Text)
'シート名
Set write_sh = write_wb.Worksheets(Me.sheetname.Text)
'開始行
w_start_row = Me.start_row.Text
'最終行をカウントする列
w_key_col = Me.key_col.Text
'書き込み対象列項目名
w_colname = Me.colname.Text
'書き込み項目番号
w_colnum = Me.colnum.Text
'結合文字
Dim srtjoin As String
srtjoin = Me.join_str.Text
'結合対象項目（1+2+3）
Dim srtjoin_num As String
srtjoin_num = Me.join_num.Text
Dim max_row_key As Long
max_row_key = getMaxRow(write_sh, w_key_col)
Dim max_col_key As Long
max_col_key = getMaxCol(write_sh, w_start_row - 1)
'入力値をバックアップ
With ThisWorkbook.Sheets("config")
.Range("STR_FILE").Value = Me.filename.Text
.Range("STR_SHEET").Value = Me.sheetname.Text
.Range("STR_START").Value = Me.start_row.Text
.Range("STR_JOIN").Value = Me.join_str.Text
.Range("STR_KEY_COL").Value = Me.key_col.Text
.Range("STR_JOIN_NO").Value = Me.join_num.Text
.Range("STR_COLNAME").Value = Me.colname.Text
.Range("STR_COL_NO").Value = Me.colnum.Text
.Range("STR_COLADD").Value = Me.column_addname.Text
End With
'status
status_lb = "データ取得中・・・"
DoEvents
If Me.colname.Text = "最終列以降（右端に出力）" Then
write_sh.Cells(w_start_row - 1, Int(Me.colnum.Text)).Value = Me.column_addname.Text
End If
'指定列の文字列連結
' join_concatenation(シート（Worksheet）, _
target_col（String） 例：1+3+4, _
最終（Long）行, _
ヘッダー番号（Long）, _
結合文字（String） , _
戻り値：出力配列（String）)
' 戻り値：Boolean
Dim b
Dim result() As String
b = join_concatenation_addin(write_sh, _
srtjoin_num, _
max_row_key, _
w_start_row - 1, _
srtjoin, _
result)
write_sh.Range(write_sh.Cells(w_start_row, w_colnum), write_sh.Cells(max_row_key, w_colnum)) = result
'status
Me.status_lb = "処理完了"
MsgBox "完了！", vbInformation
End Sub
'ファイル名
Private Sub filename_Change()
'ブックが変更されたらシート名を反映
Dim sheet_list As Variant
sheet_list = book_sheets_list(Workbooks(Me.filename.Value))
Dim v As Variant
Me.sheetname.Clear
For Each v In sheet_list
Me.sheetname.AddItem v
Next
'デフォルトで表示させる値
' Me.sheetname.ListIndex = 0
With ThisWorkbook.Sheets("config")
Me.sheetname.Text = .Range("STR_SHEET").Value
End With
'アクティブシート名
If Me.sheetname.Text = "" Then
Me.sheetname.Text = ActiveSheet.Name
End If
End Sub
'シート名
Private Sub sheetname_Change()
'シートが変更されたら
'開始行
Me.start_row.Text = ThisWorkbook.Sheets("config").Range("STR_START").Value
End Sub
'開始行
Private Sub start_row_Change()
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
If Me.start_row.Value = "" Then
Exit Sub
End If
With ThisWorkbook.Sheets("config")
'シートがあるか
If sheets_exists(Workbooks(Me.filename.Value), Me.sheetname.Value) Then
'最終列
max_col = getMaxCol(Workbooks(Me.filename.Value).Worksheets(Me.sheetname.Value), Int(Me.start_row.Text) - 1)
Else
'シートがない場合
'最終列
max_col = getMaxCol(Workbooks(Me.filename.Value).Worksheets(1), Int(Me.start_row.Text) - 1)
End If
End With
With ThisWorkbook.Sheets("config")
'シートがあるか
If sheets_exists(Workbooks(Me.filename.Value), Me.sheetname.Value) Then
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.filename.Value).Worksheets(Me.sheetname.Value), Int(Me.start_row.Text) - 1, max_col)
Else
'シートがない場合
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.filename.Value).Worksheets(1), Int(Me.start_row.Text) - 1, max_col)
End If
End With
'対象列項目名
Me.colname.Clear
For Each v In col_list
Me.colname.AddItem v
Next
'デフォルトで表示させる値
Me.colname.AddItem "最終列以降（右端に出力）"
With ThisWorkbook.Sheets("config")
Me.colname.Text = .Range("STR_COLNAME").Value
Me.colnum.Text = .Range("STR_COL_NO").Value
Me.column_addname.Text = .Range("STR_COLADD").Value
End With
'configに値がなければ、"最終列以降（右端に出力）"を表示
If Me.colname.Text = "" Then
Me.colname.Text = "最終列以降（右端に出力）"
End If
End Sub
'書き込み項目名
Private Sub colname_Change()
'項目名が変更されたら書き込み先の項目番号を反映
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
Dim i As String
With ThisWorkbook.Sheets("config")
'シートがあるか
If sheets_exists(Workbooks(Me.filename.Value), Me.sheetname.Value) Then
'最終列
max_col = getMaxCol(Workbooks(Me.filename.Value).Worksheets(Me.sheetname.Value), Int(Me.start_row.Text) - 1)
Else
'シートがない場合
'最終列
max_col = getMaxCol(Workbooks(Me.filename.Value).Worksheets(1), Int(Me.start_row.Text) - 1)
End If
End With
With ThisWorkbook.Sheets("config")
'シートがあるか
If sheets_exists(Workbooks(Me.filename.Value), Me.sheetname.Value) Then
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.filename.Value).Worksheets(Me.sheetname.Value), Int(Me.start_row.Text) - 1, max_col)
Else
'シートがない場合
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.filename.Value).Worksheets(1), Int(Me.start_row.Text) - 1, max_col)
End If
End With
Me.colnum.Text = ""
i = 0
For Each v In col_list
i = i + 1
If v = Me.colname.Text Then
Exit For
End If
Next
If "最終列以降（右端に出力）" = Me.colname.Text Then
i = i + 1
column_addname.Enabled = True
Else
column_addname.Enabled = False
End If
Me.colnum.Text = i
End Sub
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
アドバンスフィルタ
F03_advancedfilter
Option Explicit
'セル名前
''書き込み
' 'ファイル名
' AD_FILE
' 'シート名
' AD_SHEET
' 'テーブルの位置
' AD_TB
' '設定シート名
' AD_CONF
'■設定シート入力例
'空白以外
'<>
'空白
'=
'任意の1文字を表す
'?BC
'任意の複数文字列を表す
'*BC
'AND
'例：項目Aが値１かつ、項目Bが値２を抽出
'項目A 項目B
'値１ 値２
'OR
'例：項目Aが値１または、項目Bが値２を抽出
'項目A 項目B
'値１ 空白
'空白 値２
'使用するObject名
'
'ファイル名
'filename
'シート名
'sheetname
'テーブルの位置（入力例：A1）
'table_position
'設定シート名
'config_sheet
'
'
'出力先
'ファイル名
'copy_filename
'シート名
'copy_sheetname
'
'
'フィルター オプションボタン
'fill
'フィルターコピー オプションボタン
'copy_fill
'
'
'フィルター解除
'cmd_release
'
'実行
'cmd_execute
Private Sub UserForm_Initialize()
Dim book_list As Variant
Dim v As Variant
With ThisWorkbook.Sheets("config")
'テーブルの位置
If .Range("AD_TB").Value = "" Then
Me.table_position.Text = "A1"
Else
Me.table_position.Text = .Range("AD_TB").Value
End If
'設定シート名
If .Range("AD_CONF").Value = "" Then
Me.config_sheet.Text = "config"
Else
Me.config_sheet.Text = .Range("AD_CONF").Value
End If
'読み込み先
'ファイル名
book_list = open_book_list
For Each v In book_list
Me.filename.AddItem v
Next
'ファイル名
If .Range("AD_FILE").Value = "" Then
'デフォルトで表示させる値
Me.filename.Text = ActiveWorkbook.Name
Else
Me.filename.Text = .Range("AD_FILE").Value
End If
End With
'書き込み先
'ファイル名
book_list = open_book_list
For Each v In book_list
Me.copy_filename.AddItem v
Next
'ファイル名
'If .Range("AD_FILE").Value = "" Then
'デフォルトで表示させる値
' Me.copy_filename.Text = ActiveWorkbook.Name
'Else
'' Me.copy_filename.Text = .Range("AD_FILE").Value
'End If
End Sub
Private Sub cmd_END_Click()
Unload Me
End Sub
Private Sub cmd_INIT_Click()
Call advancedfilter_addin_Init
End Sub
Private Sub cmd_release_Click()
On Error GoTo ErrHandler
ActiveSheet.ShowAllData
ErrHandler:
End Sub
Private Sub filename_Change()
'ブックが変更されたらシート名を反映
Dim sheet_list As Variant
sheet_list = book_sheets_list(Workbooks(Me.filename.Value))
Dim v As Variant
Me.sheetname.Clear
For Each v In sheet_list
Me.sheetname.AddItem v
Next
'デフォルトで表示させる値
' Me.write_sheetname.ListIndex = 0
With ThisWorkbook.Sheets("config")
Me.sheetname.Text = .Range("AD_SHEET").Value
End With
'アクティブシート名
If Me.sheetname.Text = "" Then
Me.sheetname.Text = ActiveSheet.Name
End If
End Sub
Private Sub copy_filename_Change()
'書き込み先 ブックが変更されたらシート名を反映
Dim sheet_list As Variant
sheet_list = book_sheets_list(Workbooks(Me.copy_filename.Value))
Dim v As Variant
Me.copy_sheetname.Clear
For Each v In sheet_list
Me.copy_sheetname.AddItem v
Next
'デフォルトで表示させる値
' Me.write_sheetname.ListIndex = 0
' With ThisWorkbook.Sheets("config")
' Me.copy_sheetname.Text = .Range("AD_SHEET").Value
' End With
'アクティブシート名
If Me.copy_sheetname.Text = "" Then
Me.copy_sheetname.Text = ActiveSheet.Name
End If
End Sub
Private Sub cmd_execute_Click()
Dim d
Dim table_position As String
Dim config_sheet As String
Dim conf_sh As Worksheet
'ブック
Set read_wb = Workbooks(Me.filename.Text)
'シート名
Set read_sh = read_wb.Worksheets(Me.sheetname.Text)
'テーブルの位置
table_position = Me.table_position.Text
'設定シート名
config_sheet = Me.config_sheet.Text
'設定シート範囲
'シート
Set conf_sh = read_wb.Worksheets(config_sheet)
Me.status_lb = "処理中"
DoEvents
'チェック判定
If copy_fill.Value = True Then
'出力ブック
Set write_wb = Workbooks(Me.copy_filename.Text)
'出力シート名
'シートがあるか 'シートがない場合は作成する
If sheets_exists(write_wb, Me.copy_sheetname.Value) Then
Set write_sh = write_wb.Worksheets(Me.copy_sheetname.Text)
Else
'シートがない場合
Set write_sh = Worksheets.Add()
write_sh.Name = Me.copy_sheetname.Text
End If
'######################################################
'機能：アドバンスドフィルタ コピー
' advance_filter_copy（リスト範囲, 検索条件範囲, 抽出範囲)
'戻り値：Boolean
'######################################################
d = advance_filter_copy(read_sh.Range(table_position).CurrentRegion, conf_sh.Range("A1").CurrentRegion, write_sh.Range(table_position).CurrentRegion)
'出力件数カウント
Me.copy_fill_out_count.Caption = "出力件数(A列)：" & WorksheetFunction.Subtotal(3, write_sh.Range("A1").CurrentRegion.Columns(1))
Else
'######################################################
'機能：アドバンスドフィルタ
' advance_filter(リスト範囲, 検索条件範囲) ByVal target_range As Range, ByVal Conf_Range As Range
'戻り値：Boolean
'######################################################
d = advance_filter(read_sh.Range(table_position).CurrentRegion, conf_sh.Range("A1").CurrentRegion)
'出力件数カウント
Me.fill_out_count.Caption = "出力件数(A列)：" & WorksheetFunction.Subtotal(3, read_sh.Range("A1").CurrentRegion.Columns(1))
End If
'status
Me.status_lb = "処理完了"
MsgBox "完了！", vbInformation
End Sub
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
CSV ⇒ xlsb 変換
Option Explicit
'使用するObject名
'
'対象フォルダ
'folderpath
'
'フォルダ選択
'cmd_fol_select
'
'実行
'cmd_execute
Private Sub cmd_END_Click()
Unload Me
End Sub
Private Sub cmd_fol_select_Click()
Dim folderpath As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
folderpath = .SelectedItems(1)
End With
'Debug.Print "選択したフォルダパス：" & folderpath
Me.folderpath.Text = folderpath
End Sub
Private Sub cmd_execute_Click()
Dim tdate As String
Dim v As Variant
Dim files() As String
Dim wb As Workbook
Dim save_filepath As String
'停止
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = False
End With
'対象フォルダ内に「yyyymmdd_csv_to_xlsb」を生成
'日付を文字列に変換(例：日付⇒「YYYY-MM-DD」などに変換)
tdate = date_to_string(Date, "")
'フォルダ作成
If os_mkdir(Me.folderpath.Text, tdate & "_csv_to_xlsb") Then
End If
'対象フォルダ内にあるCSVファイルをループで処理
'ファイル一覧を取得
files = os_listdir(Me.folderpath.Text)
For Each v In files
If Not Right(v, 3) = "csv" Then
GoTo loopskip
End If
Me.status_lb = "処理中: " & v
DoEvents
'新しいブックを生成
Workbooks.Add
Set wb = ActiveWorkbook
'CSVファイル読み込み（クエリで256カラムを全て文字列）
If csv_import_qr_addin(Me.folderpath.Text & "\" & v, wb.Sheets(1)) Then
End If
'xlsbで保存
save_filepath = Me.folderpath.Text & "\" & tdate & "_csv_to_xlsb" & "\" & v & ".xlsb"
wb.SaveAs save_filepath, FileFormat:=xlExcel12 ' FileFormat:=xlExcel12はバイナリーブック
wb.Close
loopskip:
Next
'有効化
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.DisplayAlerts = True
.Cursor = xlDefault
.StatusBar = False
End With
' Set fso = Nothing
MsgBox "完了", vbInformation
End Sub
Private Sub Frame1_Click()
End Sub
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
差分抽出
Option Explicit
'使い方
'比較対象のCSV、2ファイルをExcelにインポート実行する
'結果
'「yyyymmdd_差分抽出」シートのA列に判定される
'条件
'１行目にヘッダーがある想定
'A列で最終行を取っている
'文字列結合文字はアンダースコア
'使用するObject名
'
'対象シートA
'sheetname_a
'
'対象シートB
'sheetname_b
'
'
'実行
'cmd_execute
Private Sub UserForm_Initialize()
' Me.sheetname_a.Text = "Sheet1"
' Me.sheetname_b.Text = "Sheet2"
Dim sheet_list As Variant
Dim v As Variant
sheet_list = book_sheets_list(ActiveWorkbook)
Me.sheetname_a.Clear
For Each v In sheet_list
Me.sheetname_a.AddItem v
Next
'アクティブシート名
If Me.sheetname_a.Text = "" Then
Me.sheetname_a.Text = ActiveSheet.Name
End If
sheet_list = ""
sheet_list = book_sheets_list(ActiveWorkbook)
Me.sheetname_b.Clear
For Each v In sheet_list
Me.sheetname_b.AddItem v
Next
'アクティブシート名
If Me.sheetname_b.Text = "" Then
Me.sheetname_b.Text = ActiveSheet.Name
End If
End Sub
Private Sub cmd_END_Click()
Unload Me
End Sub
Private Sub cmd_execute_Click()
Dim sheet_a As String
Dim sheet_b As String
sheet_a = Me.sheetname_a.Text
sheet_b = Me.sheetname_b.Text
Dim ws_sheet_a As Worksheet
Dim ws_sheet_b As Worksheet
Set ws_sheet_a = ActiveWorkbook.Sheets(sheet_a)
Set ws_sheet_b = ActiveWorkbook.Sheets(sheet_b)
Dim tdate As String
Dim out_sheet As String
Dim ws_out_sheet As Worksheet
Dim max_row As Long
Dim max_col As Long
Dim srtjoin_num As String
Dim i As Long
Dim b
Dim result() As String
'停止
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = False
End With
'「yyyymmdd_差分抽出」シート作成
tdate = date_to_string(Date, "")
out_sheet = tdate & "_差分抽出"
'シート存在チェック
If sheets_exists(ActiveWorkbook, out_sheet) Then
ActiveWorkbook.Sheets(out_sheet).Cells.ClearContents
Set ws_out_sheet = ActiveWorkbook.Sheets(out_sheet)
Else
Set ws_out_sheet = Worksheets.Add()
ws_out_sheet.Name = out_sheet
End If
'データがあるか
max_row = getMaxRow(ws_sheet_a, 1)
max_col = getMaxCol(ws_sheet_a, 1)
'０件なら終了
If max_row = 1 Then
MsgBox Me.sheetname_a.Text & "データがありません。A列で最終行を取っています", vbInformation
GoTo err
End If
max_row = getMaxRow(ws_sheet_b, 1)
max_col = getMaxCol(ws_sheet_b, 1)
If max_row = 1 Then
MsgBox Me.sheetname_b.Text & "データがありません。A列で最終行を取っています", vbInformation
GoTo err
End If
'「yyyymmdd_差分抽出」シートのB列に「対象シートA」で指定したシートのデータを全て結合して転記
max_row = getMaxRow(ws_sheet_a, 1)
max_col = getMaxCol(ws_sheet_a, 1)
'結合するキーを生成 例：1+3+4
srtjoin_num = ""
For i = 1 To max_col
srtjoin_num = srtjoin_num & i & "+"
Next i
srtjoin_num = Left(srtjoin_num, Len(srtjoin_num) - 1)
'指定列の文字列連結
' join_concatenation(シート（Worksheet）, _
target_col（String） 例：1+3+4, _
最終（Long）行, _
ヘッダー番号（Long）, _
結合文字（String） , _
戻り値：出力配列（String）)
b = join_concatenation_main_addin(ws_sheet_a, _
srtjoin_num, _
max_row, _
1, _
"_", _
result)
ws_out_sheet.Range(ws_out_sheet.Cells(1, 2), ws_out_sheet.Cells(max_row - 1, 2)) = result
'「yyyymmdd_差分抽出」シートのC列に「対象シートB」で指定したシートのデータを全て結合して転記
max_row = getMaxRow(ws_sheet_b, 1)
max_col = getMaxCol(ws_sheet_b, 1)
'結合するキーを生成 例：1+3+4
srtjoin_num = ""
For i = 1 To max_col
srtjoin_num = srtjoin_num & i & "+"
Next i
srtjoin_num = Left(srtjoin_num, Len(srtjoin_num) - 1)
'指定列の文字列連結
' join_concatenation(シート（Worksheet）, _
target_col（String） 例：1+3+4, _
最終（Long）行, _
ヘッダー番号（Long）, _
結合文字（String） , _
戻り値：出力配列（String）)
b = join_concatenation_main_addin(ws_sheet_b, _
srtjoin_num, _
max_row, _
1, _
"_", _
result)
ws_out_sheet.Range(ws_out_sheet.Cells(1, 3), ws_out_sheet.Cells(max_row - 1, 3)) = result
'「yyyymmdd_差分抽出」シートのA列にて不一致判定
' =EXACT(B1,C1)
max_row = getMaxRow(ws_out_sheet, 2)
For i = 1 To max_row
If ws_out_sheet.Cells(i, 2).Value = ws_out_sheet.Cells(i, 3).Value Then
ws_out_sheet.Cells(i, 1) = True
Else
ws_out_sheet.Cells(i, 1) = False
End If
Next i
'FALSEがある場合はフィルターして表示
If Application.WorksheetFunction.CountIf(ws_out_sheet.Range("A:A"), "FALSE") >= 0 Then
ws_out_sheet.Range("A:A").AutoFilter Field:=1, Criteria1:="FALSE"
End If
MsgBox "完了", vbInformation
err:
'有効化
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.DisplayAlerts = True
.Cursor = xlDefault
.StatusBar = False
End With
' Set fso = Nothing
End Sub
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
CSVを指定シートに読込
Option Explicit
'使用するObject名
'
'対象ファイル
'filepath
'
'出力シート
'out_sheetname
'
'ファイル選択
'cmd_fol_select
'
'実行
'cmd_execute
Private Sub UserForm_Initialize()
Me.out_sheetname.Text = "Sheet1"
End Sub
Private Sub cmd_END_Click()
Unload Me
End Sub
Private Sub cmd_fol_select_Click()
Dim path As Variant
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
' .Filters.Add "Excel2003", "*.xls"
' .Filters.Add "Excelファイル", "*.xlsx"
' .Filters.Add "Excelマクロ有効", "*.xlsm"
.Filters.Add "CSV", "*.CSV"
' .InitialFileName = "D:\user"
.AllowMultiSelect = False
If .Show = True Then
'CSV開く
' .Execute
End If
path = .SelectedItems(1)
End With
Me.filepath.Text = path
End Sub
Private Sub cmd_execute_Click()
'Dim tdate As String
'Dim v As Variant
'Dim files() As String
Dim wb As Workbook
'Dim save_filepath As String
Dim sheetname As String
'停止
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.DisplayAlerts = False
.Cursor = xlWait
.StatusBar = False
End With
sheetname = Me.out_sheetname.Text
Set wb = ActiveWorkbook
'CSVファイル読み込み（クエリで256カラムを全て文字列）
If csv_import_qr(Me.filepath.Text, wb.Sheets(sheetname)) Then
End If
'有効化
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.DisplayAlerts = True
.Cursor = xlDefault
.StatusBar = False
End With
' Set fso = Nothing
MsgBox "完了", vbInformation
End Sub
Private Sub UserForm_Click()
End Sub
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
（countif）指定Aの項目の値が指定Bの項目にあるか
Option Explicit
'（countif）指定Aの項目の値が指定Bの項目にあるか
'使用するObject名
'書き込み先
'ファイル名
'write_filename
'シート名
'write_sheetname
'keyの列
'write_key
'書き込み対象項目名
'write_colname
'最終列以降（右端に出力）の項目名
'write_column_addname
'開始行
'write_start_row
'keyが何列目にあるか
'write_key_col
'書き込み対象項目何列目にあるか
'write_colnum
'
'
'
'読み込み先
'
'ファイル名
'read_filename
'シート名
'read_sheetname
'keyの列
'read_key
'読み込み対象項目名
'read_colname
'開始行
'read_start_row
'keyが何列目にあるか
'read_key_col
'
'
'実行
'cmd_execute
'
Private Sub UserForm_Initialize()
'開いてるブックの一覧 書き込み、読み込み共通
Dim book_list As Variant
Dim v As Variant
'keyの列
Me.write_key_col.Text = 1
Me.read_key_col.Text = 1
'ファイル一覧
book_list = open_book_list
For Each v In book_list
Me.write_filename.AddItem v
Me.read_filename.AddItem v
Next
''入力値を復元
With ThisWorkbook.Sheets("config")
'書き込み
'ファイル名
Me.write_filename.Text = ActiveWorkbook.Name
'対象列項目名
Me.write_column_addname.Text = "カウント"
'読み込み
'ファイル名
Me.read_filename.Text = ActiveWorkbook.Name
End With
End Sub
Private Sub cmd_END_Click()
Unload Me
End Sub
Private Sub cmd_execute_Click()
Dim result() As String
Dim org_datalist() As String
Dim result_not_overwriting() As String
Dim output_range As Range
Dim v As Variant
Dim i As Long
Dim rc As Integer
Dim max_row_key As Long
Dim max_row_ref As Long
Dim max_col_key As Long
Dim max_col_ref As Long
Dim cnt As Long
rc = MsgBox("実行しますか？", vbYesNo + vbQuestion, "確認")
If rc = vbNo Then
Exit Sub
End If
'どれか空白があったらエラーを表示
'書き込み
If Me.write_filename.Text = "" Then
MsgBox "書き込み ファイル名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_sheetname.Text = "" Then
MsgBox "書き込み シート名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_key.Text = "" Then
MsgBox "書き込み keyの列が入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_key_col.Text = "" Then
MsgBox "書き込み keyが何列目にあるかが入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_colname.Text = "" Then
MsgBox "書き込み 対象列項目名を取得するための列が入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_colnum.Text = "" Then
MsgBox "書き込み 対象項目が何列目にあるかが入力されてません", vbExclamation
Exit Sub
ElseIf Me.write_column_addname.Text = "" Then
MsgBox "書き込み 最終列以降の項目が入力されてません", vbExclamation
Exit Sub
'読み込み
ElseIf Me.read_filename.Text = "" Then
MsgBox "読み込み ファイル名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.read_sheetname.Text = "" Then
MsgBox "読み込み シート名が入力されてません", vbExclamation
Exit Sub
ElseIf Me.read_start_row.Text = "" Then
MsgBox "読み込み 開始行が入力されてません", vbExclamation
Exit Sub
ElseIf Me.read_key.Text = "" Then
MsgBox "読み込み keyの列が入力されてません", vbExclamation
Exit Sub
ElseIf Me.read_key_col.Text = "" Then
MsgBox "読み込み keyが何列目にあるかが入力されてません", vbExclamation
Exit Sub
End If
'ブック
Set write_wb = Workbooks(Me.write_filename.Text)
Set read_wb = Workbooks(Me.read_filename.Text)
'シート名
Set write_sh = write_wb.Worksheets(Me.write_sheetname.Text)
Set read_sh = read_wb.Worksheets(Me.read_sheetname.Text)
'開始行
w_start_row = Me.write_start_row.Text
ref_start_row = Me.read_start_row.Text
'keyの列
w_key_col = Me.write_key_col.Text
ref_key_col = Me.read_key_col.Text
'書き込み対象列項目名
w_colname = Me.write_colname.Text
'読み込み対象列項目名
' ref_colname = Me.read_colname.Text
'書き込み項目番号
w_colnum = Me.write_colnum.Text
'読み込み項目番号
' ref_colnum = Me.read_colnum.Text
'最終行
max_row_key = getMaxRow(write_sh, w_key_col)
max_row_ref = getMaxRow(read_sh, ref_key_col)
'最終列
max_col_key = getMaxCol(write_sh, w_start_row - 1)
max_col_ref = getMaxCol(read_sh, ref_start_row - 1)
'status
status_lb = "データ取得中・・・"
DoEvents
Set output_range = write_sh.Range(write_sh.Cells(w_start_row, w_colnum), write_sh.Cells(max_row_key, w_colnum))
If Me.write_colname.Text = "最終列以降（右端に出力）" Then
write_sh.Cells(w_start_row - 1, Int(Me.write_colnum.Text)).Value = Me.write_column_addname.Text
End If
' Countif
' addin_count_if(検索値（範囲）, 検索範囲, 出力範囲)
' 戻り値：Boolean
If addin_count_if(write_sh.Range(write_sh.Cells(w_start_row, w_key_col), write_sh.Cells(max_row_key, w_key_col)), _
read_sh.Range(read_sh.Cells(ref_start_row, 1), read_sh.Cells(max_row_ref, max_col_ref)), _
output_range) Then
End If
'' pd_merge(検索値（範囲）, 検索範囲, 列番号（取得したい列）, 出力範囲)
' If pd_merge_addin(write_sh.Range(write_sh.Cells(w_start_row, w_key_col), write_sh.Cells(max_row_key, w_key_col)), _
' read_sh.Range(read_sh.Cells(ref_start_row, 1), read_sh.Cells(max_row_ref, max_col_ref)), _
' ref_colnum, _
' output_range, _
' result) Then
' End If
' output_range.Value = org_datalist
'status
Me.status_lb = "処理完了"
MsgBox "完了！", vbInformation
'
' Dim result() As String
' Dim org_datalist() As String
' Dim result_not_overwriting() As String
' Dim output_range As Range
' Dim v As Variant
' Dim i As Long
' Dim rc As Integer
' Dim max_row_key As Long
' Dim max_row_ref As Long
' Dim max_col_key As Long
' Dim max_col_ref As Long
' Dim cnt As Long
'
'
' rc = MsgBox("実行しますか？", vbYesNo + vbQuestion, "確認")
' If rc = vbNo Then
' Exit Sub
' End If
'
''上書きチェック アラート 元データの項目名を指定でチェックが入ってる場合
' If write_column_addname.Enabled = False Then
' If Me.write_overwriting_execution.Value = True Then
' rc = MsgBox("上書きされますがよろしいですか？", vbYesNo + vbQuestion, "確認")
' If rc = vbNo Then
' Exit Sub
' End If
' End If
' End If
'
'
''どれか空白があったらエラーを表示
''書き込み
' If Me.write_filename.Text = "" Then
' MsgBox "書き込み ファイル名が入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.write_sheetname.Text = "" Then
' MsgBox "書き込み シート名が入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.write_key.Text = "" Then
' MsgBox "書き込み keyの列が入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.write_key_col.Text = "" Then
' MsgBox "書き込み keyが何列目にあるかが入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.write_colname.Text = "" Then
' MsgBox "書き込み 対象列項目名を取得するための列が入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.write_colnum.Text = "" Then
' MsgBox "書き込み 対象項目が何列目にあるかが入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.write_column_addname.Text = "" Then
' MsgBox "書き込み 最終列以降の項目が入力されてません", vbExclamation
' Exit Sub
'
''読み込み
' ElseIf Me.read_filename.Text = "" Then
' MsgBox "読み込み ファイル名が入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.read_sheetname.Text = "" Then
' MsgBox "読み込み シート名が入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.read_start_row.Text = "" Then
' MsgBox "読み込み 開始行が入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.read_key.Text = "" Then
' MsgBox "読み込み keyの列が入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.read_key_col.Text = "" Then
' MsgBox "読み込み keyが何列目にあるかが入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.read_colname.Text = "" Then
' MsgBox "読み込み 対象列項目名が入力されてません", vbExclamation
' Exit Sub
' ElseIf Me.read_colnum.Text = "" Then
' MsgBox "読み込み 対象項目が何列目にあるかが入力されてません", vbExclamation
' Exit Sub
' End If
'
'
''入力値をバックアップ
'With ThisWorkbook.Sheets("config")
''書き込み
' 'ファイル名
' .Range("WRITE_FILE").Value = Me.write_filename.Text
' 'シート名
' .Range("WRITE_SHEET").Value = Me.write_sheetname.Text
' '開始行
' .Range("WRITE_START").Value = Me.write_start_row.Text
' 'keyの列
' .Range("WRITE_KEY").Value = Me.write_key.Text
' 'keyが何列目にあるか
' .Range("WRITE_KEY_NO").Value = Me.write_key_col.Text
' '対象列項目名
' .Range("WRITE_NAME").Value = Me.write_colname.Text
' '対象項目が何列目にあるか
' .Range("WRITE_NAME_NO").Value = Me.write_colnum.Text
' '最終列以降の項目
' .Range("WRITE_END_NAME").Value = Me.write_column_addname.Text
'
''読み込み
' 'ファイル名
' .Range("READ_FILE").Value = Me.read_filename.Text
' 'シート名
' .Range("READ_SHEET").Value = Me.read_sheetname.Text
' '開始行
' .Range("READ_START").Value = Me.read_start_row.Text
' 'keyの列
' .Range("READ_KEY").Value = Me.read_key.Text
' 'keyが何列目にあるか
' .Range("READ_KEY_NO").Value = Me.read_key_col.Text
' '対象列項目名
' .Range("READ_NAME").Value = Me.read_colname.Text
' '対象項目が何列目にあるか
' .Range("READ_NAME_NO").Value = Me.read_colnum.Text
'
''値がない場合の反映値
' .Range("P_NOT_ASSOCIATED").Value = Me.write_not_associated.Text
' not_associated = Me.write_not_associated.Text
'End With
'
' 'ブック
' Set write_wb = Workbooks(Me.write_filename.Text)
' Set read_wb = Workbooks(Me.read_filename.Text)
'
' 'シート名
' Set write_sh = write_wb.Worksheets(Me.write_sheetname.Text)
' Set read_sh = read_wb.Worksheets(Me.read_sheetname.Text)
'
' '開始行
' w_start_row = Me.write_start_row.Text
' ref_start_row = Me.read_start_row.Text
'
' 'keyの列
' w_key_col = Me.write_key_col.Text
' ref_key_col = Me.read_key_col.Text
'
' '書き込み対象列項目名
' w_colname = Me.write_colname.Text
'
' '読み込み対象列項目名
' ref_colname = Me.read_colname.Text
'
' '書き込み項目番号
' w_colnum = Me.write_colnum.Text
' '読み込み項目番号
' ref_colnum = Me.read_colnum.Text
'
'
' '最終行
' max_row_key = getMaxRow(write_sh, w_key_col)
' max_row_ref = getMaxRow(read_sh, ref_key_col)
'
' '最終列
' max_col_key = getMaxCol(write_sh, w_start_row - 1)
' max_col_ref = getMaxCol(read_sh, ref_start_row - 1)
'
' 'status
' status_lb = "データ取得中・・・"
' DoEvents
'
' Set output_range = write_sh.Range(write_sh.Cells(w_start_row, w_colnum), write_sh.Cells(max_row_key, w_colnum))
' If Me.write_colname.Text = "最終列以降（右端に出力）" Then
' write_sh.Cells(w_start_row - 1, Int(Me.write_colnum.Text)).Value = Me.write_column_addname.Text
' End If
'
'' pd_merge(検索値（範囲）, 検索範囲, 列番号（取得したい列）, 出力範囲)
' If pd_merge_addin(write_sh.Range(write_sh.Cells(w_start_row, w_key_col), write_sh.Cells(max_row_key, w_key_col)), _
' read_sh.Range(read_sh.Cells(ref_start_row, 1), read_sh.Cells(max_row_ref, max_col_ref)), _
' ref_colnum, _
' output_range, _
' result) Then
' End If
'
''上書きにチェックが入ってるか
' If Me.write_overwriting_execution.Value = True Then
' '上書きする
' output_range.Value = result
'
' Else
' '上書きしない
' '元データを配列に格納
' cnt = output_range.Rows.Count
' ReDim org_datalist(1 To cnt, 1 To 1)
' i = 1
' For Each v In output_range
' org_datalist(i, 1) = v
' i = i + 1
' Next
'
' '機能：上書きするかしないか 配列を加工する
' Call arrmake_overwriting_addin(org_datalist, result)
'
' output_range.Value = org_datalist
'
' End If
'
''status
'Me.status_lb = "処理完了"
'MsgBox "完了！", vbInformation
End Sub
'------------------------------------------------------------------
'書き込み先設定
'------------------------------------------------------------------
'書き込み先 ファイル名
Private Sub write_filename_Change()
'ブックが変更されたら書き込み先シート名を反映
Dim sheet_list As Variant
sheet_list = book_sheets_list(Workbooks(Me.write_filename.Value))
'シートの一覧
Dim v As Variant
Me.write_sheetname.Clear
For Each v In sheet_list
Me.write_sheetname.AddItem v
Next
'デフォルトで表示させる値
' Me.write_sheetname.ListIndex = 0
Me.write_sheetname.Text = Workbooks(Me.write_filename.Value).Sheets(1).Name
End Sub
'書き込み先 シート名
Private Sub write_sheetname_Change()
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
'シートが変更されたら
'シートが未設定のとき
If Me.write_sheetname.Text = "" Then
Me.write_sheetname.Text = Workbooks(Me.write_filename.Value).Sheets(1).Name
End If
'開始行設定デフォルト
Me.write_start_row.Text = 2
Call write_start_row_Change
End Sub
'開始行
Private Sub write_start_row_Change()
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
If Me.write_start_row.Value = "" Then
Exit Sub
End If
'最終列
max_col = getMaxCol(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1, max_col)
'key
Me.write_key.Clear
For Each v In col_list
Me.write_key.AddItem v
Next
'デフォルトで表示させる値
Me.write_key.ListIndex = 0
'書き込み対象列項目名
Me.write_colname.Clear
For Each v In col_list
'keyは項目に入れない
If Not Me.write_key.Text = v Then
Me.write_colname.AddItem v
End If
Next
Me.write_colname.AddItem "最終列以降（右端に出力）"
'"最終列以降（右端に出力）"を表示
If Me.write_colname.Text = "" Then
Me.write_colname.Text = "最終列以降（右端に出力）"
End If
End Sub
'書き込み先 キーの列
Private Sub write_key_Change()
'項目名が変更されたら書き込み先の項目番号を反映
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
Dim i As String
'最終列
max_col = getMaxCol(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1, max_col)
Me.write_key_col.Text = ""
i = 0
For Each v In col_list
i = i + 1
If v = Me.write_key.Text Then
Exit For
End If
Next
Me.write_key_col.Text = i
End Sub
'書き込み先 書き込み対象列項目名
Private Sub write_colname_Change()
'項目名が変更されたら書き込み先の項目番号を反映
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
Dim i As String
'最終列
max_col = getMaxCol(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.write_filename.Value).Worksheets(Me.write_sheetname.Value), Int(Me.write_start_row.Text) - 1, max_col)
Me.write_colnum.Text = ""
i = 0
For Each v In col_list
i = i + 1
If v = Me.write_colname.Text Then
Exit For
End If
Next
If Me.write_colname.Text = "最終列以降（右端に出力）" Then
i = i + 1
write_column_addname.Enabled = True
Else
write_column_addname.Enabled = False
End If
Me.write_colnum.Text = i
End Sub
'------------------------------------------------------------------
'読み込み先設定
'------------------------------------------------------------------
'読み込み先 ファイル名
Private Sub read_filename_Change()
'ブックが変更されたら書き込み先シート名を反映
Dim sheet_list As Variant
sheet_list = book_sheets_list(Workbooks(Me.read_filename.Value))
Dim v As Variant
Me.read_sheetname.Clear
For Each v In sheet_list
Me.read_sheetname.AddItem v
Next
'デフォルトで表示させる値
' Me.read_sheetname.ListIndex = 0
Me.read_sheetname.Text = Workbooks(Me.read_filename.Value).Sheets(1).Name
End Sub
'読み込み先 シート名
Private Sub read_sheetname_Change()
'シートが変更されたら
'シートが未設定のとき
If Me.read_sheetname.Text = "" Then
Me.read_sheetname.Text = Workbooks(Me.read_filename.Value).Sheets(1).Name
End If
'開始行設定デフォルト
Me.read_start_row.Text = 2
Call read_start_row_Change
End Sub
'開始行
Private Sub read_start_row_Change()
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
If Me.read_start_row.Value = "" Then
Exit Sub
End If
On Error GoTo ErrHandler
'最終列
max_col = getMaxCol(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1, max_col)
'key
Me.read_key.Clear
For Each v In col_list
Me.read_key.AddItem v
Next
'デフォルトで表示させる値
Me.read_key.ListIndex = 0
ErrHandler:
End Sub
'読み込み先 キーの列
Private Sub read_key_Change()
'キーの列が変更されたら書き込み先の項目番号を反映
Dim col_list As Variant
Dim max_col As Long
Dim v As Variant
Dim i As String
'最終列
max_col = getMaxCol(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1)
'項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
col_list = Array_ColmunsName(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1, max_col)
Me.read_key_col.Text = ""
i = 1
For Each v In col_list
If v = Me.read_key.Text Then
Exit For
End If
i = i + 1
Next
Me.read_key_col.Text = i
End Sub
''読み込み先 読み込み対象列項目名
'Private Sub read_colname_Change()
' '読み込み対象列項目名が変更されたら書き込み先の項目番号を反映
' Dim col_list As Variant
' Dim max_col As Long
' Dim v As Variant
' Dim i As String
'
'
' '最終列
' max_col = getMaxCol(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1)
'
' '項目名を配列に格納 'Array_ColmunsName（シートオブジェクト, ヘッダー番号, 最終列)
' col_list = Array_ColmunsName(Workbooks(Me.read_filename.Value).Worksheets(Me.read_sheetname.Value), Int(Me.read_start_row.Text) - 1, max_col)
'
' Me.read_colnum.Text = ""
' i = 1
' For Each v In col_list
' If v = Me.read_colname.Text Then
' Exit For
' End If
' i = i + 1
' Next
' Me.read_colnum.Text = i
'End Sub
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
addin集
Option Explicit
'全てA1選択（アクティブブック）
Sub all_a1_select()
Dim i As Long
Dim sheet_list As Variant
For i = 0 To ActiveWorkbook.Sheets.Count - 1
'非表示の場合は無視する
If Not ActiveWorkbook.Sheets(i + 1).Visible = False Then
ActiveWorkbook.Sheets(i + 1).Select
Range("A1").Select
End If
Next i
Dim WSH As Object
Set WSH = CreateObject("WScript.Shell")
WSH.Popup "完了", 1, "Title", vbInformation
Set WSH = Nothing
End Sub
'保存して閉じる
Sub save_close()
Dim rc As Integer
rc = MsgBox("保存して閉じますか？", vbYesNo + vbQuestion, "確認")
If rc = vbNo Then
Exit Sub
End If
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
'フィルター解除
Sub fillter_on_off()
If auto_filter_on_off(ActiveSheet, 1, False) Then
End If
End Sub
'アクティブシート内のセルの色を初期化
Sub 色を戻す()
ActiveSheet.Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
'ブック内のシート全てフィルター解除
Sub all_sheets_fillter_off()
Dim i As Long
Dim sheet_list As Variant
For i = 0 To ActiveWorkbook.Sheets.Count - 1
'非表示の場合は無視する
If Not ActiveWorkbook.Sheets(i + 1).Visible = False Then
' ActiveWorkbook.Sheets(i + 1).Select
' Range("A1").Select
If auto_filter_on_off(ActiveSheet, 1, False) Then
End If
End If
Next i
Dim WSH As Object
Set WSH = CreateObject("WScript.Shell")
WSH.Popup "完了", 1, "Title", vbInformation
Set WSH = Nothing
End Sub
'R1C1参照方式切り替え
Sub addin_r1c1_chg()
If Application.ReferenceStyle = xlA1 Then
Application.ReferenceStyle = xlR1C1
Else
Application.ReferenceStyle = xlA1
End If
End Sub
'アクティブブックを保存しないで閉じて開きなおす
Sub nosave_reopen()
Dim rc As Integer
rc = MsgBox("開きなおしますか？保存されません", vbYesNo + vbQuestion, "確認")
If rc = vbNo Then
Exit Sub
End If
'ThisWorkbook.Saved = True このコードでExcelに保存したと思わせることができるだけで
' 実際に保存されるわけではない 保存しますか？のダイアログ非表示にすることが出来る
ThisWorkbook.Saved = True
ThisWorkbook.ChangeFileAccess xlReadOnly, , False
Application.Wait Now + TimeValue("00:00:01")
ThisWorkbook.ChangeFileAccess xlReadWrite, , True
End Sub
'アドイン用グループ化集計マクロ カウントと合計
'例 A列に果物の入ったデータがあり、B列に個数。果物ごとに合計いくつあるのかカウントする。
Sub addin_グループ化集計(search_col As Long, sum_col As Long, start_row As Long)
Dim i As Long
Dim dic_Count As Object
Dim dic_Sum As Object
'Dim start_row As Long
Dim out_Row As Long
Dim wKey As String
Dim varKeys As Variant
Dim var As Variant
Dim rc As Integer
'集計対象シート
Dim target_sheet As Worksheet
Set target_sheet = ActiveSheet
'出力シート
Dim out_sheet As Worksheet
''検索カラム位置
'Dim search_col As Long
'search_col = 1
''合計カラム位置
'Dim sum_col As Long
'sum_col = 2
''データ開始行
'start_row = 2
''出力カラム位置
Dim out_col As Long
out_col = 1
'集計シートがあるか ある場合はA～C列が初期化されることをアラートを表示
'シート存在チェック
If Not sheets_exists(ActiveWorkbook, "集計") Then
ActiveWorkbook.Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "集計"
Else
rc = MsgBox("集計が既にあります。A～C列がクリアされ上書きますがいいですか？", vbYesNo + vbQuestion, "確認")
If rc = vbNo Then
Exit Sub
End If
End If
Set out_sheet = ActiveWorkbook.Sheets("集計")
out_sheet.Range("A:C").ClearContents
'指定範囲のデータを取得
Set dic_Count = CreateObject("Scripting.Dictionary")
Set dic_Sum = CreateObject("Scripting.Dictionary")
i = start_row
Do Until target_sheet.Cells(i, search_col).Value = ""
wKey = target_sheet.Cells(i, search_col).Value
If dic_Count.Exists(wKey) Then
'カウントアップ
dic_Count.Item(wKey) = CLng(dic_Count.Item(wKey)) + 1
'数値加算
dic_Sum.Item(wKey) = CLng(dic_Sum.Item(wKey)) + _
CLng(target_sheet.Cells(i, sum_col).Value)
Else
'未登録の場合は新規登録
dic_Count.Add wKey, 1
dic_Sum.Add wKey, target_sheet.Cells(i, sum_col).Value
End If
i = i + 1
Loop
'キー項目の配列を取得
varKeys = dic_Count.Keys
out_Row = 2 '出力データ開始行
i = out_Row
'集計項目の表示
'ヘッダーをセット
out_sheet.Cells(out_Row - 1, out_col).Value = target_sheet.Cells(start_row - 1, search_col).Value
out_sheet.Cells(out_Row - 1, out_col + 1).Value = "値の数カウント"
out_sheet.Cells(out_Row - 1, out_col + 2).Value = "合計"
For Each var In varKeys
'検索値
out_sheet.Cells(i, out_col).Value = var
'カウント
out_sheet.Cells(i, out_col + 1).Value = dic_Count.Item(var)
'合計
out_sheet.Cells(i, out_col + 2).Value = dic_Sum.Item(var)
'平均
' out_sheet.Cells(wRow, out_col + ３).Value = _
' dic_Sum.Item(var) / dic_Count.Item(var)
i = i + 1
Next
Set dic_Count = Nothing
Set dic_Sum = Nothing
'totalの合計値
Dim maxrow As Long
maxrow = getMaxRow(out_sheet, out_col + 1)
out_sheet.Cells(maxrow + 1, out_col + 1).Value = Application.WorksheetFunction.Sum(out_sheet.Range(out_sheet.Cells(2, out_col + 1), out_sheet.Cells(maxrow, out_col + 1)))
out_sheet.Cells(maxrow + 1, out_col + 2).Value = Application.WorksheetFunction.Sum(out_sheet.Range(out_sheet.Cells(3, out_col + 2), out_sheet.Cells(maxrow, out_col + 2)))
Dim WSH As Object
Set WSH = CreateObject("WScript.Shell")
WSH.Popup "完了", 1, "Title", vbInformation
Set WSH = Nothing
End Sub
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
共通関数
Option Explicit
'環境設定変数群
'obj
Public fso As New FileSystemObject
'ブック
Public write_wb As Workbook
Public read_wb As Workbook
'シート名
Public write_sh As Worksheet
Public read_sh As Worksheet
'開始行
Public w_start_row As Long
Public ref_start_row As Long
'keyの列
Public w_key_col As Long
Public ref_key_col As Long
'完全一致
Public perfect_match As String
'上書き実行
Public overwriting_execution As String
'値がない場合の反映値
Public not_associated As String
'書き込み対象列項目名
Public w_colname As String
'読み込み対象列項目名
Public ref_colname As String
'書き込み項目番号
Public w_colnum As Long
'読み込み項目番号
Public ref_colnum As Long
Sub tests()
Dim book_list As Variant
book_list = open_book_list
book_list = book_sheets_list(ActiveWorkbook)
End Sub
Sub vlook_addin_show()
F01_vlook.Show
End Sub
Sub vlook_addin_Init()
Unload F01_vlook
F01_vlook.Show
End Sub
Sub string_join_addin_show()
F02_string_join.Show
End Sub
Sub string_join_addin_Init()
Unload F02_string_join
F02_string_join.Show
End Sub
Sub advancedfilter__addin_show()
F03_advancedfilter.Show
End Sub
Sub advancedfilter_addin_Init()
Unload F03_advancedfilter
F03_advancedfilter.Show
End Sub
Sub csv_to_xlsb_show()
F04_csv_to_xlsb.Show
End Sub
Sub csv_import_out_sheet_show()
F07_csv_import_out_sheet.Show
End Sub
Sub 差分抽出_show()
F05_差分抽出.Show
End Sub
Sub グループ化集計_show()
F08_グループ化集計.Show
End Sub
Sub ファイル取得系_show()
F09_ファイル取得系_要修正.Show
End Sub
Sub countif_show()
F10_countif.Show
End Sub
'######################################################
'紐づけ １列 Vlookアドイン用
' pd_merge(検索値（範囲）, 検索範囲, 列番号（取得したい列）, 出力範囲, 戻り値：結果を配列で返す)
'戻り値：Boolean
'######################################################
Public Function pd_merge_addin(ByVal target_range As Range, ByVal search_range As Range, ByVal col_num As Long, ByVal output_range As Range, ary() As String) As Boolean
Dim dic As New Dictionary
Dim i As Long
Dim v
pd_merge_addin = False
'KEYと取得したい列の値をセットで格納
For i = 1 To search_range.Rows.Count
If Not dic.Exists(CStr(search_range(i, ref_key_col).Value)) Then
dic.Add CStr(search_range(i, ref_key_col).Value), search_range(i, col_num).Value
End If
Next
ReDim Preserve ary(1 To output_range.Rows.Count, 1 To 1)
Dim s As String
For i = 1 To target_range.Rows.Count
'status
F01_vlook.status_lb = "レコード数：" & target_range.Rows.Count & "件 " & "処理中・・・" & str(Int(100 * Format(i / target_range.Rows.Count, ""))) + "%"
DoEvents
'完全一致
If F01_vlook.write_perfect_match.Value = True Then
s = dic.Item(CStr(target_range(i, 1).Value))
Else
For Each v In dic.Items
If InStr(v, CStr(target_range(i, 1).Value)) > 0 Then
s = v
Exit For
End If
Next
End If
'紐づかない場合の反映値
If Not s = "" Then
ary(i, 1) = s
Else
ary(i, 1) = not_associated
End If
Next
pd_merge_addin = True
Set dic = Nothing
End Function
'######################################################
'指定列の文字列連結 F02_string_join専用
' join_concatenation(シート（Worksheet）, _
target_col（String） 例：1+3+4, _
最終（Long）行, _
ヘッダー番号（Long）, _
結合文字（String） , _
戻り値：出力配列（String）)
' 戻り値：Boolean
'######################################################
'メモ
'文字列連結方法
'「&」記号を使う方法 遅い
'Join関数を使う方法 高速 (配列の場合はJOINを使う、全てカンマ区切りにするときなど、二次元配列はJOINできない）
Public Function join_concatenation_addin(ByVal sh As Worksheet, _
ByVal target_col As String, _
ByVal max_row As Long, _
ByVal header As Long, _
ByVal sfx As String, _
ByRef arr_join_concat() As String) As Boolean
Dim i As Long
Dim j As Long
Dim col As Long
Dim n As Long
Dim dataTable As Variant
Dim arrCol As Variant
Dim v As Variant
Dim c As Variant
Dim buf As String
col = UBound(Split(target_col, "+"))
arrCol = Split(target_col, "+")
n = 0
ReDim arr_join_concat(0 To max_row - header - 1, 0)
For i = header + 1 To max_row
'status
F02_string_join.status_lb = "レコード数：" & max_row & "件 " & "処理中・・・" & str(Int(100 * Format(i / max_row, ""))) + "%"
DoEvents
ReDim dataTable(0 To col)
For j = 0 To col
dataTable(j) = sh.Cells(i, Int(arrCol(j))).Value
Next j
buf = Join(dataTable, sfx)
arr_join_concat(n, 0) = Join(dataTable, sfx)
n = n + 1
Next i
End Function
'######################################################
'指定列の文字列連結 差分比較用
' join_concatenation(シート（Worksheet）, _
target_col（String） 例：1+3+4, _
最終（Long）行, _
ヘッダー番号（Long）, _
結合文字（String） , _
戻り値：出力配列（String）)
' 戻り値：Boolean
'######################################################
'メモ
'文字列連結方法
'「&」記号を使う方法 遅い
'Join関数を使う方法 高速 (配列の場合はJOINを使う、全てカンマ区切りにするときなど、二次元配列はJOINできない）
Public Function join_concatenation_main_addin(ByVal sh As Worksheet, _
ByVal target_col As String, _
ByVal max_row As Long, _
ByVal header As Long, _
ByVal sfx As String, _
ByRef arr_join_concat() As String) As Boolean
Dim i As Long
Dim j As Long
Dim col As Long
Dim n As Long
Dim dataTable As Variant
Dim arrCol As Variant
Dim v As Variant
Dim c As Variant
Dim buf As String
col = UBound(Split(target_col, "+"))
arrCol = Split(target_col, "+")
n = 0
ReDim arr_join_concat(0 To max_row - header, 0)
For i = header To max_row
ReDim dataTable(0 To col)
For j = 0 To col
dataTable(j) = sh.Cells(i, Int(arrCol(j))).Value
Next j
buf = Join(dataTable, sfx)
arr_join_concat(n, 0) = Join(dataTable, sfx)
n = n + 1
Next i
End Function
'######################################################
'機能：上書きするかしないか 配列を加工する
' arrmake_overwriting(元のセル範囲の配列 As string, 取得したデータの配列 As string,)
'戻り値：元のセル範囲の配列 As string
'######################################################
'元のセル範囲の配列と、取得したデータの配列を用意。元のセル範囲の配列をループで回して、空白があれば取得したデータの配列の該当レコードの値を入れる。
Public Function arrmake_overwriting_addin(arr_org() As String, arr() As String)
Dim v
Dim i As Long
i = 1
For Each v In arr_org
If arr_org(i, 1) = "" Then
arr_org(i, 1) = arr(i, 1)
End If
i = i + 1
Next
End Function
'######################################################
'CSVファイル読み込み（クエリで256カラムを全て文字列）
' csv_import_qr(target_path As String, out_sheet As Worksheet) As Boolean
' 戻り値：Boolean
'######################################################
Public Function csv_import_qr_addin(target_path As String, out_sheet As Worksheet) As Boolean
'文字列として取り込む方法
'TextFileColumnDataTypes = Array(xlTextFormat, xlTextFormat, xlTextFormat, ・・・
'TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2・・・
'TextFileColumnDataTypesについて
'定数 値 説明
'xlGeneralFormat(既定値) 1 一般
'xlTextFormat 2 文字列
'xlMDYFormat 3 MDY日付形式
'xlDMYFormat 4 DMY日付形式
'xlYMDFormat 5 YMD日付形式
'xlMYDFormat 6 MYD日付形式
'xlDYMFormat 7 DYM日付形式
'xlYDMFormat 8 YDM日付形式
'xlSkipColumn 9 スキップ（その列を取り込みたくない場合）
'xlEMDFormat 10 EMD日付形式
'文字コード指定
'Shift-JIS 932
'UTF-8 65001
'UTF-16 1200
'デフォルトでダブルクォーテーションを削除するかどうか
'xlTextQualifierNone 引用符なし
'xlTextQualifierDoubleQuote ダブルクォーテーション
'xlTextQualifierSingleQuote シングルクォーテーション
Dim CharSet As String
Dim qtCsv As QueryTable
Dim arr As Variant
Dim i As Long
'出力シート初期化
out_sheet.Cells.ClearContents
'カラムを文字列化するため以下をセットする
'TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2・・・
ReDim arr(255)
For i = 0 To 255
arr(i) = 2
Next i
'######################################################
'文字コードを判定
' getCharSet(Path) As String
'戻り値：String utf-8、shift_jis
'######################################################
CharSet = getCharSet(target_path)
'取り込むCSVパスと、取り込み先のシート、セルを指定
Set qtCsv = out_sheet.QueryTables.Add(Connection:="TEXT;" & target_path, _
Destination:=out_sheet.Range("A1"))
With qtCsv
'カンマ区切りの指定
.TextFileCommaDelimiter = True
' 区切り文字の形式
.TextFileParseType = xlDelimited
'書式 文字列
.TextFileColumnDataTypes = arr
'開始行の指定 CSVなら固定
.TextFileStartRow = 1
'引用符の指定 ダブルクォーテーション
.TextFileTextQualifier = xlTextQualifierDoubleQuote
'文字コードを判定
If CharSet = "shift_jis" Then
.TextFilePlatform = 932 '文字コード指定 SJIS
ElseIf CharSet = "utf-8" Then
.TextFilePlatform = 65001 '文字コード指定 UTF8
Else
MsgBox "対応してない文字コードです！CSVの文字コードを確認してください", vbExclamation
Exit Function
End If
'QueryTablesオブジェクトを更新し、シート上に出力
.Refresh
.Delete 'QueryTables.Addメソッドで取り込んだCSVとの接続を解除
End With
csv_import_qr_addin = True
End Function
'######################################################
'Countif
' addin_count_if(検索値（範囲）, 検索範囲, 出力範囲)
'戻り値：Boolean
'######################################################
Public Function addin_count_if(ByVal target_range As Range, _
ByVal search_range As Range, _
ByVal output_range As Range) As Boolean
Dim SearchArray As Variant
Dim RefArray As Variant
Dim Keyval As String
Dim MaxRowA As Long
Dim MaxRowD As Long
Dim i As Long
Dim n As Long
Dim myStr As String
Dim dic As New Dictionary
addin_count_if = False
On Error GoTo ErrHandler
SearchArray = target_range '①A列と出力用
RefArray = search_range '②参照データ
For n = 1 To UBound(RefArray) '参照用の配列を要素数分ループ
'status
F10_countif.status_lb = "レコード数：" & UBound(RefArray) & "件 " & "検索中・・・" & str(Int(100 * Format(n / UBound(RefArray), ""))) + "%"
DoEvents
Keyval = RefArray(n, 1) '③Keyを格納
'未登録の場合登録
'登録済みの場合は+1カウントアップ
If Not dic.Exists(Keyval) Then
dic.Add Keyval, 1
Else
dic(Keyval) = dic(Keyval) + 1
End If
Next n
'検索用配列の要素数分ループ
For n = 1 To UBound(SearchArray)
'status
F10_countif.status_lb = "レコード数：" & UBound(RefArray) & "件 " & "カウント中・・・" & str(Int(100 * Format(n / UBound(RefArray), ""))) + "%"
DoEvents
Keyval = SearchArray(n, 1)
If IsEmpty(dic(Keyval)) Then
SearchArray(n, 1) = 0
Else
SearchArray(n, 1) = dic(Keyval)
End If
Next n
output_range = SearchArray '結果出力
addin_count_if = True
ErrHandler:
Set dic = Nothing
End Function
■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■
A99_memo_tips
Option Explicit
'構文のテンプレ
'----------------------------------------------------------------
'for
'
' Dim i As Long
' Dim maxrow As Long
'
' maxrow = getMaxRow(Sheets(1), 1)
' For i = 1 To maxrow
'
' Next i
'
'----------------------------------------------------------------
'select case
' Select Case a
' Case 1
' 処理1
' Case 2
' 処理2
' Case 3
' 処理3
' End Select
' Select Case a
' Case Is < 2
' 処理1
' Case Is = 2
' 処理2
' Case Is > 2
' 処理3
' End Select
'----------------------------------------------------------------
Sub data_count_allsheets()
'######################################################
'全てのシートのレコード数（データ数）をカウント
'使い方：カウントを出力したいシートをアクティブにして実行
'※ 以下の定数を実行前に設定
'出力結果：A列にシート名、B列にデータ数
'######################################################
'定数
'データのキーとなる行（最終行取得）
Dim colkey As Long: colkey = 1
'データ開始行
Dim data_startrow As Long: data_startrow = 2
'出力列
Dim outcolA As Long: outcolA = 1
Dim outcolB As Long: outcolB = 2
'出力対象シート
Dim ws As Worksheet: Set ws = ActiveSheet
Dim i As Long
Dim maxrow As Long
For i = 1 To Worksheets.Count
maxrow = getMaxRow(Sheets(i), colkey)
ws.Cells(i, outcolA).Value = Sheets(i).Name
ws.Cells(i, outcolB).Value = maxrow - data_startrow + 1
Next i
End Sub
'---------------------------------------------------------------
Sub multiple_condition_decision_feature()
'######################################################
'複数条件判定機能 A項目がONで、B項目もONなら、指定項目にONを入力する機能（andとorに対応）
'使い方：以下の定数を実行前に設定
'######################################################
'定数
'最終行を取る行（最終行取得）
Dim colmax As Long: colmax = 1
'データ開始行
Dim data_startrow As Long: data_startrow = 2
'ヘッダー
Dim headrow As Long: headrow = 1
'対象シート名
Dim SHEET_NAME As String: SHEET_NAME = "TEST_DATA"
'判定対象項目A
Dim COL_NAME_A As String: COL_NAME_A = "項目A"
'判定対象項目B
Dim COL_NAME_B As String: COL_NAME_B = "項目B"
'判定値A
Dim VALUE_A As Variant: VALUE_A = 1
'判定値B
Dim VALUE_B As Variant: VALUE_B = 100
'出力列 カラム番号を指定する 0なら最終列以降に出力
Dim outcol As Long: outcol = 0
'出力値
Dim outvalue As String: outvalue = "○"
'and または or で判定するか andならTrue orならfalse
Dim and_or As Boolean: and_or = True
Dim ws As Worksheet: Set ws = Sheets(SHEET_NAME)
Dim i As Long
Dim maxrow As Long
Dim col_a As Long
Dim col_b As Long
maxrow = getMaxRow(ws, colmax)
col_a = getColPosition(ws, headrow, COL_NAME_A)
col_b = getColPosition(ws, headrow, COL_NAME_B)
If outcol = 0 Then
outcol = getMaxCol(ws, headrow) + 1
End If
With ws
For i = data_startrow To maxrow
If and_or Then
If .Cells(i, col_a).Value = VALUE_A And .Cells(i, col_b).Value = VALUE_B Then
.Cells(i, outcol).Value = outvalue
End If
Else
If .Cells(i, col_a).Value = VALUE_A Or .Cells(i, col_b).Value = VALUE_B Then
.Cells(i, outcol).Value = outvalue
End If
End If
Next i
End With
End Sub
Author And Source
この問題について(Excel TEST_リボン), 我々は、より多くの情報をここで見つけました https://qiita.com/QB1560917/items/e41674da334cb19d6dbc著者帰属：元の著者の情報は、元のURLに含まれています。著作権は原作者に属する。
Content is automatically searched and collected through network algorithms . If there is a violation . Please contact us . We will adjust (correct author information ,or delete content ) as soon as possible .