VBAメモ

提供: Programming-Knowleodge.com
移動先: 案内検索
Sub chagneBgColor2Transparent()
'
' Keyboard Shortcut: Ctrl+t
'
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 86)).Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub

Sub chagneBgColor2Yellow()
'
' Keyboard Shortcut: Ctrl+t
'
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 86)).Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .Color = RGB(255, 255, 0)
    End With
End Sub


Sub chagneBgColor2Red()
'
'
' Keyboard Shortcut: Ctrl+r
'
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 86)).Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .Color = RGB(255, 0, 0)
    End With
End Sub


Sub chagneBgColor2Gray()
'
'
' Keyboard Shortcut: Ctrl+g
'
    Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 86)).Select
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .Color = RGB(105, 105, 105)
    End With
End Sub

Sub checkOK()
    Range(Cells(ActiveCell.Row, 48), Cells(ActiveCell.Row, 48)).FormulaR1C1 = ""
    Range(Cells(ActiveCell.Row, 51), Cells(ActiveCell.Row, 51)).FormulaR1C1 = Date
    Range(Cells(ActiveCell.Row, 56), Cells(ActiveCell.Row, 56)).FormulaR1C1 = Date
    Range(Cells(ActiveCell.Row, 60), Cells(ActiveCell.Row, 60)).FormulaR1C1 = "○"
End Sub

Sub checkNG()
    Range(Cells(ActiveCell.Row, 48), Cells(ActiveCell.Row, 48)).FormulaR1C1 = ""
    Range(Cells(ActiveCell.Row, 51), Cells(ActiveCell.Row, 51)).FormulaR1C1 = Date
    Range(Cells(ActiveCell.Row, 56), Cells(ActiveCell.Row, 56)).FormulaR1C1 = Date
    Range(Cells(ActiveCell.Row, 60), Cells(ActiveCell.Row, 60)).FormulaR1C1 = "×"
End Sub

Sub checkClear()
    Range(Cells(ActiveCell.Row, 48), Cells(ActiveCell.Row, 48)).FormulaR1C1 = ""
    Range(Cells(ActiveCell.Row, 51), Cells(ActiveCell.Row, 51)).FormulaR1C1 = ""
    Range(Cells(ActiveCell.Row, 56), Cells(ActiveCell.Row, 56)).FormulaR1C1 = ""
    Range(Cells(ActiveCell.Row, 60), Cells(ActiveCell.Row, 60)).FormulaR1C1 = ""
End Sub


'ここから
Private Declare Function ShellExecute Lib "SHELL32.DLL" Alias "ShellExecuteA" (ByVal hwnd As Long, _
      ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
      ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub batsu()
'
' Keyboard Shortcut: Ctrl+t
'
    ChangeValue("×")
End Sub

Sub maru()
'
' Keyboard Shortcut: Ctrl+t
'
    ChangeValue("○")
End Sub

Sub openFile()
    
    Range(Cells(ActiveCell.Row, 3), Cells(ActiveCell.Row, 3)).Select
    
    lngRet = ShellExecute(Scr_hDC, "OPEN", _
                  Selection.value, vbNullString, CurDir(), SW_SHOWNORMAL)
 
End Sub



Sub ChangeValue(ByRef value As String)
'
' Keyboard Shortcut: Ctrl+t
'
    Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, 5)).Select
    With Selection.Interior
        .value = value
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
End Sub


Option Explicit ' 変数の宣言を必須にする
Option Base 1 ' 配列を1から始める


Dim lTmpCalcMode As Long
lTmpCalcMode = Application.Calculation

Application.ScreenUpdating = False
Application.Calculation = xlCaculationManual
Application.Interctive = False
Application.Cursor = xlWait

' Call 〜処理

Application.ScreenUpdating = True
Application.Calculation = lTmpCalcMode
Application.Interctive = True
Application.Cursor = xlDefault


Option Explicit ' 変数の宣言を必須にする
Option Base 1 ' 配列を1から始める


' 設定シート(Sheet2)の表開始位置
Private Const START_INDEX = 2



Sub MakeFileList()
    Dim i As Integer ' 設定シートを走査するためのループ用変数
    Dim j As Integer ' 設定シートで指定されたフォルダの中を走査するためのループ用変数
    
    Dim FS As Object
    Dim Fol As Object
    Dim Fil As Object
    Dim Fx As Object
    
    Dim strFile As String
    Dim strFType As String
    Dim strLMod As String
    Dim strParentFolder As String
    
    Dim strTarget As String
    
    Dim count As Integer
    
    
    count = ThisWorkbook.Sheets("Sheet2").Range("A1").End(xlDown).Row
    
    ThisWorkbook.Sheets("Sheet1").UsedRange.Delete
    
    
    Call CreateHeader
    
    j = 3
    For i = START_INDEX To count
        strTarget = ThisWorkbook.Sheets("Sheet2").Cells(i, 2)
    
        Set FS = CreateObject("Scripting.FileSystemObject")
        Set Fol = FS.GetFolder(strTarget)
        Set Fil = Fol.Files
        
        
        For Each Fx In Fil
            'ファイルパスの書き出し
            ThisWorkbook.Sheets(1).Cells(j, 2) = Fx.Path
            
            'ファイル名の書き出し
            ThisWorkbook.Sheets(1).Cells(j, 3) = Fx.Name
            
            'ファイル種別の書き出し
            ThisWorkbook.Sheets(1).Cells(j, 5) = Fx.Type
           
            strParentFolder = Dir(Fx.ParentFolder, vbDirectory)
            ThisWorkbook.Sheets(1).Cells(j, 6) = strParentFolder
           
           
            '最終更新日
            strLMod = Fx.DateLastModified

            j = j + 1
        Next
    Next
 End Sub
 
 
 Sub CreateHeader()
        '見出しを付ける
        ThisWorkbook.Sheets(1).Range("B2") = "ファイルパス"
        ThisWorkbook.Sheets(1).Range("C2") = "ファイル名"
        ThisWorkbook.Sheets(1).Range("D2") = "ファイルパス"
        ThisWorkbook.Sheets(1).Range("E2") = "ファイル種別"
        ThisWorkbook.Sheets(1).Range("F2") = "親フォルダ"
        ThisWorkbook.Sheets(1).Range("G2") = "説明"
        ThisWorkbook.Sheets(1).Range("B2:G2").Interior.Color = RGB(0, 0, 0)
        ThisWorkbook.Sheets(1).Range("B2:G2").Font.Color = RGB(255, 255, 255)
        ThisWorkbook.Sheets(1).Range("B2:G2").HorizontalAlignment = xlCenter
 End Sub

Hashを使う

Dim dict As Object

Set dict = CreateObject("Scripting.Dictionary")

' 追加
dict.Add "index", "value"

'取り出し
For Each key In dict
 〜 = dict.Item(key)
Next key


行の重複排除

RemoveDuplicatesを使用する。第一引数で、重複するデータが含まれている列番号を指定する。

Worksheets("hogehoge").Range("A1:Z10").RemoveDuplicates(Array(1,2,3), xlYes)



RemoveDuplicatesを使う上での注意

「Option Base 1」を指定し、1からインデックスが始まる配列を渡すと、必ずエラーになるので注意が必要。
RemoveDuplicatesを使うときは、Option Base 1はやめる。
すでにつけている場合は、モジュールをわける。(RemoveDuplicatesを呼び出すモジュールだけ専用につくるしかない・・・)

DoEventsをうまく使う

この方法が一番良さげだったのでメモ DoEventsをうまく使う|Sunvisor Lab