【マクロ】スライサーの作成

テーブル名「TTBB1」のスライサーを別シートに作成する。

必ず、スライサーを作成したいシートをアクティブにしてマクロを実行すること。

さらにスライサー名の後ろに文字(1-1)を追加する。 

Sub test()
Dim wb As Workbook, sh As Worksheet, ob As ListObject
Dim Lsh As Worksheet, r As Range, mk As String
Set wb = ActiveWorkbook: Set sh = wb.ActiveSheet
Set Lsh = Sheets("テーブル") 'ここでテーブルTTBB1のあるシートを指定する
Set ob = Lsh.ListObjects("TTBB1"): Set r = sh.Range("K3")
mk = "(1-1)" 'スライサー名の後ろに追加する文字

With wb.SlicerCaches.Add2(ob, "日付")
.SortItems = xlSlicerSortDescending
.Slicers.Add sh, , , "日付" & mk, r.Top, r.Left, r.Resize(, 3).Width, r.Height * 15
End With
With wb.SlicerCaches.Add2(ob, "コード1")
.Slicers.Add sh, , , "コード1" & mk, Range("O3").Top, Range("O3").Left, 144, 233
End With
With wb.SlicerCaches.Add2(ob, "コード2")
.Slicers.Add sh, , , "コード2" & mk, Range("O20").Top, Range("O20").Left, 144, 233
End With
With wb.SlicerCaches.Add2(ob, "件名")
.Slicers.Add sh, , , "件名" & mk, Range("Q3").Top, Range("Q3").Left, 144, 233
End With
With wb.SlicerCaches.Add2(ob, "備考")
.Slicers.Add sh, , , "備考" & mk, Range("U3").Top, Range("U3").Left, 144, 233
End With
End Sub

【マクロ】ファイル開くダイアログ

Sub 個人日報フォルダ()

Dim strPath As String

strPath = "\\LANDISK06\disk1\CTI_TEMP\EXCEL日報"

With Application.FileDialog(msoFileDialogOpen)

.InitialFileName = strPath

.Show

If .SelectedItems.Count = 0 Then

'MsgBox "キャンセルされました。"

Exit Sub

End If

strPath = .SelectedItems(1)

End With

Workbooks.Open strPath

End Sub 

【マクロ】特定の文字から左を削除する

 特定の文字から左を削除する 

この場合はアンダーバーより左を削除する

selectionではなくRangeで範囲指定しても良い。

Offset(0,1)にすると隣の列に書き出してくれる。

Dim r As Range

For Each r In Selection '範囲

r.Offset(0, 0) = Right(r, Len(r) - InStr(1, r, "_")) '特定文字

Next

マクロ】A列の一番下の空白セルをアクティブにする

  次のサンプルは、データが入力されたシートでA列の最終行から上方向に終端セルをさがし、その1行下のセルを選択します。

Sub Sample1()

    Dim Last_Row As Long

    Last_Row = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

    Cells(Last_Row + 1, 1).Select

End Sub

または、Offsetプロパティと組み合わせて下記のように1行で行うこともできます。

Sub Sample2()

    ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select

End Sub

【マクロ】記述を抜く

  アンケートなどの記述を抜き出す

抜き出した値は常の下に下に追加される

Set r2 = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

下に追加したくなければ上記コードを

Set r2 = ws2.Rnge("A2")

とすれば、常にA2セルから書き出す

Sub kijyutunuku()

Dim ws2 As Worksheet, rc1 As Range, rr1 As Range

Dim r2 As Range

Set ws2 = Worksheets("Sheet2") '書き出すシート

Set r2 = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) '書き出すセルはA列の最終セル

ws2.Range("A1:F1").Value = Array("日付", "問", "Ｎｏ", "住まい", "年代", "記述")

With Worksheets("Sheet1") '元データのあるシート

For Each rc1 In .Range("E1", .Cells(1, Columns.Count).End(xlToLeft))

If rc1.Value Like "*記述" Then '項目名に【記述】がある時、

'仮に記述の列に何も記載がない（データが項目行のみ）と言う場合を除く

If WorksheetFunction.CountA(rc1.EntireColumn) > 1 Then

'ある列の記述がデータとして入っているセルだけを選び出す

Set rr1 = .Range(rc1.Offset(1), .Cells(Rows.Count, rc1.Column).End(xlUp)).SpecialCells(xlCellTypeConstants, 3)

Intersect(rr1.EntireRow, .Range("A:D")).Copy r2

rr1.Copy r2.Offset(, 5)

'書き出したシートの記述の文字を削除する

r2.Offset(, 1).Resize(rr1.Cells.Count).Value = Replace(rc1.Value, "記述", "")

Set r2 = r2.Offset(rr1.Cells.Count)

End If

End If

Next

End With

Set ws2 = Nothing

Set rr1 = Nothing

End Sub

マクロ】隠しシートを再表示出来ないようにする(右クリック再表示を押せないようにする)

  非表示にしたシートをオペレーションで再表示できないようにする

Sub SheetToVeryHidden()

     ' シートを隠す(ツールバーの再表示に表示させない)

     Worksheets("Sheet2").Visible = xlVeryHidden             ' ←非表示(VeryHidden)

End Sub

' 隠したシートを再表示

Sub SheetToVisible()

     ' 隠したシートを再表示

    Worksheets("Sheet2").Visible = xlSheetVisible            ' ←表示

    ' 再表示したシートを選択

    Worksheets("Sheet2").Select

End Sub

【マクロ】ボタンひとつで表示、非表示の切替をする

 コマンドボタン1つに「シート全体を表示・非表示する」VBAコードを書くことにより、スイッチのオン・オフのような操作ができるようにする

Private Sub CommandButton1_Click()

With Worksheets(“sheet1”)

.Visible = Not .Visible

End With

End Sub

【マクロ】必要な項目列のデータのみ別シートに抽出する

 Sub 列抽出()

Dim データ範囲 As Range

Dim 抽出列 As Variant

Dim i As Long

Set データ範囲 = ActiveSheet.Range("A1").CurrentRegion

　抽出列 = Array(1, 3)

　Sheets.Add.Name = "抽出"

For i = 0 To UBound(抽出列)

　データ範囲.Columns(抽出列(i)).Copy Sheets("抽出").Range("A1").Offset(0, i)

Next i

End Sub

↑を改造して抽出シート値貼り付け時に下へ下へと貼り付けていく

Dim datahani, r As Range, sh1 As Worksheet

Dim harituke As Variant

Dim i As Long

Set sh1 = Worksheets("teble")

Set r = Worksheets("抽出").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

sh1.Select

Set datahani = Intersect(Range("A2").CurrentRegion, Range("A2:AH20000"))

  harituke = Array(1, 2, 8, 5, 9)

  

For i = 0 To UBound(harituke)

  datahani.Columns(harituke(i)).Copy r.Offset(0, i)

Next i

【マクロ】シートを追加して名前を付ける

 

下記コードはシートを追加し年月の名前をつける

    Worksheets.Add(After:=Worksheets(Worksheets.Count)) _

        .Name = Year(Now) & "年" & Month(Now) & "月"

【マクロ】ユーザーフォームを自動で閉じる

 ------------------------------------------------ 

フォームを開くコードをModuleに記入する

'モジュールに書き込む

Sub Sample()

    UserForm1.Show   

End Sub

-----------------------------------------------

ユーザーフォーム自体に下記コードを記入

'ユーザーフォームに書き込む

Private Sub UserForm_Activate()

       Dim 指定時刻 As String

    '現在時刻より3秒

    指定時刻 = Now + TimeValue("00:00:10")   

    Application.Wait (指定時刻)

        Unload Me

End Sub

【マクロ】フォルダ内のファイルコピペ

 Sub ファイルコピペ()

     

    Dim Path As String

    Dim CopyPath As String

    Dim FName As String

     

    Path = "Z:\EXCEL日報\2021年度csv\"'コピー元のフォルダパス

    CopyPath = "Z:\EXCEL日報\読み取り専用csv\"'コピー先のフォルダパス

     

     

    FName = Dir(Path & "*.csv")'ファイルの拡張子を指定する"*.*"とすると全てのファイルになる

         

       Do While FName <> ""

       FileCopy Path & FName, CopyPath & FName

       FName = Dir()

    Loop

End Sub

【マクロ】配列を別シートに呼び出す

 

Sub 配列呼び出し()
'　使用変数の宣言
Dim sh1, sh2
Dim cData, d, c, n
'　シートを変数にセット
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
'　コピー対応データ定義
cData = Split("A2:L A2:L,AZ M,Q N,AA O,AF P,W Q", ",")
'　"A2:L A2:L,A2からL列までをA2からL列に貼り付け
’　AZ MはAZ列をM列に貼り付ける
'　使用最終行を取得
n = sh1.UsedRange.SpecialCells(xlCellTypeLastCell).Row
n = Application.Max(n - 1, 1)
'　データに基づいて各列を順にコピーを繰り返す
For Each d In cData
'　データから対応列を取得
c = Split(d, " ")
'　対応列内の値をコピー
sh2.Range(c(1) & "2").Resize(n).Value = sh1.Range(c(0) & "2").Resize(n).Value
'　繰り返し終了
Next d
End Sub

【マクロ】文字検索をして色を付ける

 

Sub kensaku()

Dim i, cnt As Long, v, F As String, c As Range

Application.ScreenUpdating = False

v = Application.InputBox("検索値は？", "値検索", Selection)

If v = "False" Or v = "" Then MsgBox "キャンセル", 64: End

Set c = Cells.Find(v, , xlValues, xlPart)

If Not c Is Nothing Then

F = c.Address

Do

c.Interior.PatternColorIndex = 6

c.Interior.Pattern = 9

c.Font.Color = 255

Set c = Cells.FindNext(c)

If c.Address = F Then Exit Do

Loop

End If

Application.ScreenUpdating = True

Application.OnKey "{f3}", "FontC"

Application.OnKey "^x"

End Sub

Sub FontC()

Application.ScreenUpdating = False

  Cells.Select

    With Selection.Interior

        .Pattern = xlNone

        .TintAndShade = 0

        .PatternTintAndShade = 0

    End With

    With Selection.Font

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

         Range("A1").Select

        

    End With

Application.ScreenUpdating = True

End Sub