vba 忘備録

'■日付を8桁で取得
Dim strYYYYMMDD
strYYYYMMDD = Format(Now, "yyyymmdd")

'■ログインユーザー名を取得する
Dim loginUser As String
loginUser = CreateObject("WScript.Network").UserName

'■拡張子を外して、フィル形式を変更して保存する
Dim Fnkk As String
Fnkk = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
ActiveWorkbook.SaveAs fileName:="C:\Users\" & loginUser & "\Desktop\追加したいファイル名" & Fnkk & "_" & strYYYYMMDDSS & ".xlsx", FileFormat:=xlOpenXMLWorkbook

'■デスクトップのディレクトリ
Dim dtd As String
dtd = "C:\Users\" & loginUser & "\Desktop\"

'全てのセルの背景色リセット
Cells.Interior.ColorIndex = 0

'項目名のチェック
※ClearFormats は、書式もクリアするので、背景色だけなら、Interior.ColorIndex = 0 に変更する
Cells.Interior.ColorIndex = 0
If Cells(1, 1).Value = "項目1" And Cells(1, 2).Value = "項目2" And Cells(1, 3).Value = "項目3" Then
Cells(1, 1).ClearFormats '←ここ注意
Cells(1, 2).ClearFormats '←ここ注意
Cells(1, 3).ClearFormats '←ここ注意
Else
Cells(1, 1).Interior.Color = RGB(255, 0, 0)
Cells(1, 2).Interior.Color = RGB(255, 0, 0)
Cells(1, 3).Interior.Color = RGB(255, 0, 0)
MsgBox "項目が正しいか確認！"
Exit Sub
End If

'1行目を追加
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

'複数セルが選択されているときは、中止する
If Selection.Count = 1 Then
Else
MsgBox "複数セルが選択されています！"
Exit Sub
End If

'選択セルの行番号取得
Dim ActRow As Long
ActRow = ActiveCell.Row

'8と10以外が入力されていると注意する
Zkubn = Cells(ActRow, 24).Value
If Zkubn = 8 Or Zkubn = 10 Then
Else
MsgBox "税率が未入力または、違います！"
Exit Sub
End If

'選択セルの書式設定の変更（abc を 【abc】 へ）
Selection.NumberFormatLocal = """【""@""】"""

'■半角変換（カナは全角）※全セルチェック２　※空白シートなら処理しない（2段階処理）
'前処理⇒　必要なセルのみ選択してせるの書式設定で「縮小して全体を表示する」
Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select '連続セルがない場合は、Cells.Selectを使う
With Selection
.ShrinkToFit = True '縮小して全体を表示する
End With
'-----------------
'後処理⇒　半角変換（カナは全角）
If WorksheetFunction.CountA(ActiveSheet.UsedRange) = 0 And ActiveSheet.Shapes.Count = 0 Then
Else
Dim hnh1 As Range
Dim hnh2 As String
Dim hnh3 As String
Dim hnhi As Long
Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Offset(1).Resize(Selection.Rows.Count - 1).Select
For Each hnh1 In Selection
hnh2 = StrConv(hnh1.Text, vbWide)
For hnhi = 1 To Len(hnh2)
hnh3 = StrConv(Mid(hnh2, hnhi, 1), vbNarrow)
If Asc(hnh3) >= 32 And Asc(hnh3) <= 126 Then _ hnh2 = WorksheetFunction.Replace(hnh2, hnhi, 1, hnh3) Next hnhi hnh1 = hnh2 Next End If '置換処理（mL処理）、複数列を選択 Columns("O:Q").Select Selection.Replace What:="ML", Replacement:="mL" Selection.Replace What:="Ml", Replacement:="mL" Selection.Replace What:="ml", Replacement:="mL" ' csvで書き出す csv書き出し ActiveWorkbook.SaveAs fileName:=bname + ".csv", FileFormat:=xlCSV 'ブックを上書き保存する ActiveWorkbook.Save '■名前の定義を削除する（ただしこの場合は消せない名前の定義もある） Dim namaet As Name For Each namaet In ActiveWorkbook.Names On Error Resume Next ' エラーを無視。 namaet.Delete Next '■非表示シートがあった場合、どうするか選択確認（はい選択はシート削除、いいえはマクロ停止） Dim hish As Worksheet If MsgBox("非表示シートをすべて削除しますか？", vbYesNo + vbDefaultButton2) = vbNo Then Exit Sub Application.DisplayAlerts = False For Each hish In Worksheets If hish.Visible = xlSheetHidden Then hish.Delete Next hish '■行列の最終入力セルの場所 最終行　最終列 Dim Maxrow, MaxCol As String With ActiveSheet.UsedRange Maxrow = .Find("*", , , , xlByRows, xlPrevious).Row MaxCol = .Find("*", , , , xlByColumns, xlPrevious).Column End With ■シート毎に処理をする方法 '■ここから先は、シート毎の対応============================================= Dim unsh As Worksheet 'シート毎の処理 For Each unsh In Worksheets unsh.Activate 'シート毎の対応======================================================== '■行列の最終入力セルの場所 Dim MaxRow2, MaxCol2 As String With ActiveSheet.UsedRange MaxRow2 = .Find("*", , , , xlByRows, xlPrevious).Row MaxCol2 = .Find("*", , , , xlByColumns, xlPrevious).Column End With 'J列に項目名入力（企画） Cells(1, 10) = "企画" 'J列にシート名を入力 Dim jrs For jrs = 2 To MaxRow2 Cells(jrs, 10) = ActiveSheet.Name Next jrs '■関数飛ばし Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues '■シートをアクティブにして、オートフィルタとウインドウ枠の固定を解除（全シート対象） ActiveSheet.AutoFilterMode = False ActiveWindow.FreezePanes = False '■マージ解除 Cells.Select Cells.MergeCells = False 'シート毎対応終わり===================================================== Next unsh Worksheets(1).Select 'シート毎対応終わり===================================================== ■複数シートを１つにする '複数シートの結合マクロ（2段階処理） '前処理⇒　「全データ」シートがあればクリア、無ければ新規作成 Dim newSh As String Dim Sh As Worksheet, myFlag As Boolean newSh = "全データ" myFlag = False For Each Sh In ThisWorkbook.Worksheets If Sh.Name = newSh Then myFlag = True Worksheets(newSh).Cells.ClearContents '全データシートクリア Worksheets(newSh).Move before:=Sheets(1) Exit For End If Next Sh If myFlag = False Then '全データシートを先頭へ追加します ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh End If '----------------- '後処理⇒　複数シートのデータを「全データ」シートへコピーする Dim fssi As Integer Dim lRow As Long, lCol As Long, lRow2 As Long Application.ScreenUpdating = False Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1") '項目コピー For fssi = 2 To Worksheets.Count With Worksheets(fssi) lRow = .Cells(Rows.Count, 1).End(xlUp).Row lCol = .Cells(1, Columns.Count).End(xlToLeft).Column If lRow >= 2 Then 'シートのデータが2行以上の場合のみコピー
lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
.Activate
.Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1)
End If
End With
Next fssi
Worksheets(1).Activate
Range("A1").Select
Application.ScreenUpdating = True
'-----------------

'■フリガナ削除
Cells.Select
Selection.Characters.PhoneticCharacters = ""

'■空白処理（前後のスペースは削除、途中の連続スペースは一つにするスペース処理）※全セルチェック１
Dim MR, MC, MRC
For MC = 1 To MaxCol
For MR = 1 To Maxrow
MRC = Cells(MR, MC).Value
MRC = Application.WorksheetFunction.Trim(MRC)
Cells(MR, MC).Value = MRC
Next
Next

'アクティブシート以外を削除
Dim mySht As Worksheet
With Application
.DisplayAlerts = False
For Each mySht In Worksheets
If mySht.Name <> ActiveSheet.Name Then mySht.Delete
Next
End With

■横に並んでいる数字を縦に行を増やす
'行列の最終入力セルの場所
Dim MaxRowp, MaxColp As String
With ActiveSheet.UsedRange
MaxRowp = .Find("*", , , , xlByRows, xlPrevious).Row
MaxColp = .Find("*", , , , xlByColumns, xlPrevious).Column
End With

Dim num1, zgi
zgi = 9 'POP番号の最後の列番号■
Do Until zgi = 5 'POP番号の最初の列番号■

'最終行の取得
With ActiveSheet.UsedRange
MaxRowp = .Find("*", , , , xlByRows, xlPrevious).Row
End With
'並び替え
Range(Cells(1, "A"), Cells(MaxRowp, "BE")).Sort Key1:=Cells(1, zgi), Order1:=xlAscending, Header:=xlYes
If Cells(2, zgi).Value = "" Then
Else
'==================================================================================
'該当列のPOP数の取得
num1 = WorksheetFunction.CountA(Columns(zgi))

'POP数が入っている行を選択
Range(Cells(2, "A"), Cells(num1, "A")).EntireRow.Select

'コピー貼り付けで行を増やす
Selection.Copy
Selection.Insert Shift:=xlDown
'確認用に処理したPOP番号に色を付ける
Range(Cells(2, zgi), Cells(num1 * 2 - 1, zgi)).Interior.ColorIndex = 35
Range(Cells(2, zgi), Cells(num1, zgi)).Select

'必要なPOP番号をコピーしてPOP1に貼り付ける
Selection.Copy
Range(Cells(2, 5), Cells(num1, 5)).Select '5は両方ともPOP番号の最初の列指定■
ActiveSheet.Paste
Range(Cells(2, 6), Cells(num1, 9)).ClearContents '6はPOP番号の2番目列、9は最後の列■
'==================================================================================
End If
zgi = zgi - 1
Loop

'特定列に書式設定
Columns("U:U").Select
Selection.NumberFormatLocal = "#,##0"
'特定列に書式設定
Columns("AT").NumberFormatLocal = "K0"

Application.ScreenUpdating = False '更新しない

'繰り返し利用による名前管理の重複を防ぐ 名前の削除
On Error Resume Next
ActiveWorkbook.Names("name1").Delete
On Error Resume Next
ActiveWorkbook.Names("name2").Delete

'一番右にシートを作る
Dim sht01, shtname1, shtname2
shtname1 = Range("シート１!A1").Value
shtname2 = Left(shtname1, 6)
cnt = Worksheets.Count 'シートの数を数える
Worksheets.Add after:=Worksheets(cnt) '一番右にシート作成
ActiveSheet.Name = shtname2 'シート名を変更

'■シート２の2列目を必要列をシート３へ複製
Sheets(2).Columns(2).Copy
Worksheets(3).Columns(3).PasteSpecial (xlPasteValues)

'特定範囲で、差替キー、連名番号、店番の順で並び替え
Worksheets(3).Range("A1:H50000") _
.Sort Key1:=Range("G1"), Order1:=xlAscending, _
Key2:=Range("C1"), Order2:=xlAscending, _
Key3:=Range("E1"), Order3:=xlAscending

'外枠罫線（全体を選択して、外枠に罫線）
Dim MaxRowsw, MaxColsw As Long
With ActiveSheet.UsedRange
MaxRowsw = .Find("*", , , , xlByRows, xlPrevious).Row
MaxColsw = .Find("*", , , , xlByColumns, xlPrevious).Column
End With
Sheets(3).Range(Cells(1, 1), Cells(MaxRowsw, MaxColsw)).Borders(xlEdgeTop).Weight = xlMedium
Sheets(3).Range(Cells(1, 1), Cells(MaxRowsw, MaxColsw)).Borders(xlEdgeBottom).Weight = xlMedium
Sheets(3).Range(Cells(1, 1), Cells(MaxRowsw, MaxColsw)).Borders(xlEdgeLeft).Weight = xlMedium
Sheets(3).Range(Cells(1, 1), Cells(MaxRowsw, MaxColsw)).Borders(xlEdgeRight).Weight = xlMedium
'xlHairline 極細線,、xlThin 細線、xlMedium 中太線、xlThick 太線

'必要なセルを全部選択する
Sheets(3).Range(Cells(1, 1), Cells(MaxRowsw, MaxColsw)).Select
'縮小して全体を表示する
With Selection
.ShrinkToFit = True
End With
'フォントサイズ
With Selection.Font
.Size = 8
End With

'行の調整
Cells.Select
Selection.RowHeight = 20

'列の調整
Columns(1).ColumnWidth = 8.36

''ヘッダー処理、フッター処理
ActiveSheet.PageSetup.RightHeader = "&10&A"
ActiveSheet.PageSetup.RightFooter = "&8&Uフッター内容"

'頁の設定A4へ変更
With ActiveSheet.PageSetup
.PaperSize = xlPaperA4
End With

'ページ設定、余白、
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0.6)
.BottomMargin = Application.InchesToPoints(0.4)
.HeaderMargin = Application.InchesToPoints(0.4)
.FooterMargin = Application.InchesToPoints(0.4)
.CenterHorizontally = True
.CenterVertically = False
End With
Application.PrintCommunication = True

'ウィンドウの最大化、最小化、標準（高速化）
Application.WindowState = xlMaximized
'Application.WindowState = xlMinimized
'Application.WindowState = xlNormal

'■並べ替え（A列、B列、C列の順番）、並び替え、順番、ソート
'最終行列の取得（入力値のみ、書式有り空白セル含まず）をしてから、必要な範囲で並び替えする
Dim MaxRow_sort, MaxCol_sort As Long
With ActiveSheet.UsedRange
MaxRow_sort = .Find("*", , , , xlByRows, xlPrevious).Row
MaxCol_sort = .Find("*", , , , xlByColumns, xlPrevious).Column
End With
ActiveSheet.Range(Cells(2, 1), Cells(MaxRow_sort, MaxCol_sort)).Sort _
Key1:=ActiveSheet.Cells(1, 1), order1:=xlAscending, _
Key2:=ActiveSheet.Cells(1, 2), order2:=xlAscending, _
Key3:=ActiveSheet.Cells(1, 3), order2:=xlAscending

'書式設定
Columns(21).NumberFormatLocal = "#,##0"
Columns(23).NumberFormatLocal = "#,##0"
Columns(46).NumberFormatLocal = "K0"

'行数を再取得
Dim MaxRowAS_i As String
With ActiveSheet.UsedRange
MaxRowAS_i = .Find("*", , , , xlByRows, xlPrevious).Row
End With
'1_2 を 1 2 に分けて入力する
Dim Tana
Dim TenBan_i
For TenBan_i = 2 To MaxRowAS_i
Cells(TenBan_i, 5) = "=関数(" & Cells(TenBan_i, 4) & ")"
Cells(TenBan_i, 20) = "任意の文字"
'備考Aの分岐
Tana = Split(Cells(TenBan_i, 36), "_")
Cells(TenBan_i, 37) = Tana(0)
Cells(TenBan_i, 38) = Tana(1)
Next

'特定の列に、関数や同じ文字を入力する際に、繰り返し関数だと時間が掛かるので、時短するためにオートフィル機能をvbaで使う
'行数を再取得
Dim MaxRowAS_i As String
With ActiveSheet.UsedRange
MaxRowAS_i = .Find("*", , , , xlByRows, xlPrevious).Row
End With
'入力内容を入れる（D列の内容を左から3文字取得していき、E列に入力する場合）
Range("E2").Select
ActiveCell.FormulaR1C1 = "=left(RC[-1],3)"
Range(Cells(2, 5), Cells(MaxRowAS_i, 5)).Select
Selection.FillDown

■全てのセルの書式をクリアする
Cells.ClearFormats
シートをアクティブにしないでクリアにしたいなら、
Sheets(1).Cells.ClearFormats

■エラーを表示させずに、強制続行させる
On Error Resume Next 'エラー非表示
On Error GoTo 0 'エラー表示（通常）

■シートの保護
ActiveSheet.Protect '保護
ActiveSheet.Unprotect '保護解除

■msgboxでの改行コード
& vbCrLf &

■処理時間を測る
Dim startzikan
startzikan = Now
'====ここに処理内容====
MsgBox "start " & startzikan & vbCrLf & "end " & Now & vbCrLf & "total " & Now - startzikan

■ 共通の変数（別モジュールでも共通して変数を使う時）
Public KikaBan
※ Dim ではなく。 また、変数専用のモジュールを用意して分かりやすくしておいたほうがいい。

■ 列のアルファベットの取得 と 列番号 と 行番号の取得
Dim atvClsAbc, atvClsNum, atvRow, atvRng
atvClsAbc = Split(ActiveCell.Address, "$")(1)
atvClsNum = ActiveCell.Column & Chr(13)
atvRow = ActiveCell.Row & Chr(13)
atvRng = atvClsAbc & atvRow

■ アクティブセルの列をアルファベットで取得
Dim s As String
s = ActiveCell.Address
s = Split(ActiveCell.Address, "$")(1)

■ アクティブセルを動かしていく場合の左下ステータスバーの進捗表示
行数を...で表示させて動いている進んでいる状況を見せる
Application.StatusBar = Split(ActiveCell.Address, "$")(1) & Split(ActiveCell.Address, "$")(2) & " 処理中" & String(Int(Split(ActiveCell.Address, "$")(2) / 10), ".")

■ スリープ　一時停止　止める　処理待ち
subの上に以下を入力
'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'OSじゃなくて、Excelのソフトウェアが64bit用
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'OSじゃなくて、Excelのソフトウェアが32bit用
sub の中で、
Sleep 1000 '1秒のこと