重複確認
'◆重複をファイル出力(単一項目) Sub 重複確認() '**********************PARAM************************ Const 出力シート名 As String = "重複確認結果" '*************************************************** Dim dic As New Dictionary Dim dic_duplicate As New Dictionary '○選択範囲の値を配列に格納＞arr_Select On Error GoTo Err_Select Dim arr_Select() As Variant If Selection.Columns.Count <> 1 Or Selection.Rows.Count = 1 Then GoTo Err_Select arr_Select = Selection '○重複確認 On Error GoTo 0 Dim v As Variant For Each v In arr_Select If v = "" Then GoTo NextCell '空だったらスキップ If Not dic.Exists(v) Then dic.Add v, 1 '初見リストになければ格納 ElseIf Not dic_duplicate.Exists(v) Then dic_duplicate.Add v, 2 '重複リストになければ格納 Else dic_duplicate(v) = dic_duplicate(v) + 1 '重複件数をカウント End If NextCell: Next '○重複がなかったら終了 If dic_duplicate.Count = 0 Then MsgBox "重複はありません", vbInformation Exit Sub End If '○重複があったら新規ブックに出力 '画面更新の非表示 Application.ScreenUpdating = False 'シート追加 Workbooks.Add ActiveSheet.Name = 出力シート名 'ヘッダー名の設定 Range("A1") = "重複内容" Range("B1") = "件数" '背景色の設定 Range("A1").Interior.Color = RGB(204, 255, 255) Range("B1").Interior.Color = RGB(204, 255, 255) '書式設定を文字列に Range("A:A").NumberFormatLocal = "@" Dim iRow As Long iRow = 2 For Each v In dic_duplicate Cells(iRow, 1) = v Cells(iRow, 2) = dic_duplicate(v) iRow = iRow + 1 Next '画面更新の非表示解除 Application.ScreenUpdating = True MsgBox "処理が完了しました", vbInformation Exit Sub Err_Select: MsgBox "範囲選択エラー", vbCritical End Sub
Insert文作成
'◆Insert文を作成しテキストに出力 Sub Insert文作成() '************PARAM*********** Const 文字コード = "UTF-8" '**************************** '○選択範囲の値を配列に格納＞arr_Select On Error GoTo Err_Select Dim arr_Select() As Variant arr_Select = Selection Debug.Print arr_Select(2, 1) '○テーブル名を入力させる On Error GoTo Err Dim tableName As Variant tableName = InputBox("Insert対象のテーブル名を入力してください", "Insertテーブル確認") If tableName = "" Then Exit Sub '○保存場所を指定 Dim folderName As Variant folderName = Application.GetSaveAsFilename(InitialFileName:="ins_" & tableName & ".sql", FileFilter:="SQLファイル,*.sql") If folderName = False Then Exit Sub 'キャンセルなら終了 '○SQLにヘッダー情報を追加 Dim sql As String sql = "INSERT INTO " & tableName & " (" Dim i As Long i = 1 Do While i <= UBound(arr_Select, 2) If i <> 1 Then sql = sql & "," sql = sql & arr_Select(1, i) i = i + 1 Loop sql = sql & ") VALUES (" '○SQLを作成し、コレクションに格納＞col_Sql Dim j As Long Dim tmpSql As String Dim col_Sql As New Collection i = 2 j = 1 '縦 Do While i <= UBound(arr_Select) tmpSql = sql '横 Do While j <= UBound(arr_Select, 2) If j <> 1 Then tmpSql = tmpSql & "," tmpSql = tmpSql & "'" & arr_Select(i, j) & "'" j = j + 1 Loop tmpSql = tmpSql & ");" col_Sql.Add tmpSql i = i + 1 j = 1 Loop '○テキストに出力 Dim ado As Object Set ado = CreateObject("ADODB.Stream") '文字コードをセット ado.Charset = 文字コード ado.Open '書き込み処理 Dim v As Variant For Each v In col_Sql ado.WriteText v, adWriteLine Next ado.SaveToFile folderName, 2 ado.Close MsgBox "処理が正常終了しました", vbInformation 'ファイルを開く CreateObject("Shell.Application").ShellExecute folderName Exit Sub Err_Select: MsgBox "複数範囲を選択してください", vbCritical Exit Sub Err: MsgBox "エラー番号：" & Err.Number & vbCrLf & "エラー内容：" & Err.Description, vbOKOnly + vbCritical End Sub
セル位置整頓
'◆セルの選択位置を先頭にする(非表示を除く全シート) Sub セル位置整頓() Dim ws_Temp As Worksheet For Each ws_Temp In Worksheets ws_Temp.Activate ws_Temp.Range("A1").Select Next Sheets(1).Activate End Sub
プロパティメーカー
'************************************************** 'プロパティクラスを作成し、ファイルに出力する '-------------------------------------------------- 'セルを選択して実行する '1列目:プロパティ名 '2列目:(省略可)型 ※省略時は定数の固定型を入力 '************************************************** Sub プロパティメーカー() '定数 Const 文字コード = "UTF-8" Const 固定型 = "String" '2列目が入力されていなかった場合使用 Const プロパティ = "Private p_【名前】 As 【型】" Const ゲット = "Property Get 【名前】() As 【型】" & vbCrLf _ & " 【名前】 = p_【名前】 " & vbCrLf _ & "End Property" Const レット = "Property Let 【名前】(value As 【型】)" & vbCrLf _ & " p_【名前】 = value" & vbCrLf _ & "End Property" Const セルフ = "'自身を返す" & vbCrLf _ & "Property Get Self() As 【クラス名】" & vbCrLf _ & " Set Self = Me" & vbCrLf _ & "End Property" '○選択範囲の値をtmp_Selectに格納(複数セル選択すると配列になる) On Error GoTo Err_Select Dim tmp_Select As Variant tmp_Select = Selection '3列以上選択されていれば終了 If Selection.Columns.Count >= 3 Then GoTo Err_Select Dim i As Long: i = 1 Dim j As Long: j = 1 Dim tmp_プロパティ As String Dim tmp_メソッド As String Dim 名前 As String Dim 型 As String '単一セル選択時(tmp_Selectが配列でない) If Selection.Columns.Count = 1 And Selection.Rows.Count = 1 Then 'ブランクは対象外 If tmp_Select <> "" Then 名前 = tmp_Select 型 = 固定型 tmp_プロパティ = tmp_プロパティ & プロパティ & vbLf tmp_プロパティ = Replace(tmp_プロパティ, "【名前】", 名前) tmp_プロパティ = Replace(tmp_プロパティ, "【型】", 型) tmp_メソッド = tmp_メソッド & ゲット & vbLf & vbLf & レット & vbLf & vbLf tmp_メソッド = Replace(tmp_メソッド, "【名前】", 名前) tmp_メソッド = Replace(tmp_メソッド, "【型】", 型) End If Else '複数セル選択時(tmp_Selectが配列) Do While i <= UBound(tmp_Select) 名前 = tmp_Select(i, 1) If 名前 = "" Then GoTo NextCell '2列目を省略した場合（固定型にする） If Selection.Columns.Count = 1 Then 型 = 固定型 '2列目を指定した場合（2列目の値にする） If Selection.Columns.Count = 2 Then 型 = IIf(tmp_Select(i, 2) = "", "String", tmp_Select(i, 2)) tmp_プロパティ = tmp_プロパティ & プロパティ & vbCrLf tmp_プロパティ = Replace(tmp_プロパティ, "【名前】", 名前) tmp_プロパティ = Replace(tmp_プロパティ, "【型】", 型) tmp_メソッド = tmp_メソッド & ゲット & vbCrLf & vbCrLf & レット & vbCrLf & vbCrLf tmp_メソッド = Replace(tmp_メソッド, "【名前】", 名前) tmp_メソッド = Replace(tmp_メソッド, "【型】", 型) NextCell: i = i + 1 Loop End If '出力対象がなければ終了 If tmp_プロパティ = "" Then GoTo Err_Value '○保存場所を指定 Dim folderName As Variant folderName = Application.GetSaveAsFilename(FileFilter:="テキストファイル,*.txt") If folderName = False Then Exit Sub 'キャンセルなら終了 '○テキストに出力 On Error GoTo Err_Select Dim ado As Object Set ado = CreateObject("ADODB.Stream") '文字コードをセット ado.Charset = 文字コード ado.Open '書き込み処理 ado.WriteText tmp_プロパティ & vbCrLf, adWriteLine ado.WriteText tmp_メソッド, adWriteChar ado.WriteText セルフ, adWriteLine ado.SaveToFile folderName, 2 ado.Close '〇ファイルを開く CreateObject("Shell.Application").ShellExecute folderName Exit Sub Err_Select: MsgBox "範囲選択エラー" & vbCrLf & "※3列以上選択不可", vbCritical Exit Sub Err_Value: MsgBox "出力対象0件", vbCritical Exit Sub Err_Text: MsgBox "テキスト出力エラー", vbCritical Exit Sub End Sub
アドイン追加方法
1)アドインをxlam形式で保存
2)Excelアドイン内の参照で1で保存したアドインを選択し、有効にする
3)リボンのユーザー設定から新しいタブを追加
4)コマンドの選択でマクロを選択して追加
