vba 忘備録

2019/09/26

'■日付を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 ※空白シートなら処理しない(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 'シート毎対応終わり===================================================== ■複数シートを1つにする '複数シートの結合マクロ(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 = ""

'■空白処理(前後のスペースは削除、途中の連続スペースは一つにするスペース処理)※全セルチェック1
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("シート1!A1").Value
shtname2 = Left(shtname1, 6)
cnt = Worksheets.Count 'シートの数を数える
Worksheets.Add after:=Worksheets(cnt) '一番右にシート作成
ActiveSheet.Name = shtname2 'シート名を変更

'■シート2の2列目を必要列をシート3へ複製
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 ではなく。 また、変数専用のモジュールを用意して分かりやすくしておいたほうがいい。

スポンサーリンク

スマホのみ下に表示