カテゴリー: Excel

VBAで圧縮解凍処理を行います。

'オプションの意味：変数宣言必須
Option Explicit

'圧縮処理(実行)
Public Sub ZipSample()
  ZipFileOrFolder "C:\Test\Files" 'フォルダ圧縮
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

'解凍処理(実行)
Public Sub UnZipSample()
  UnZipFile "C:\Test\Files\Test.zip"
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

'圧縮処理
Public Sub ZipFileOrFolder(ByVal SrcPath As Variant, _
                           Optional ByVal DestFolderPath As Variant = "")
  'ファイル・フォルダをZIP形式で圧縮
  'SrcPath：元ファイル・フォルダ
  'DestFolderPath：出力先、指定しない場合は元ファイル・フォルダと同じ場所
  Dim DestFilePath As Variant

  With CreateObject("Scripting.FileSystemObject")
    If IsFolder(DestFolderPath) = False Then
      If IsFolder(SrcPath) = True Then
        DestFolderPath = SrcPath
      ElseIf IsFile(SrcPath) = True Then
        DestFolderPath = .GetFile(SrcPath).ParentFolder.Path
      Else: Exit Sub
      End If
    End If
    DestFilePath = AddPathSeparator(DestFolderPath) & _
                     .GetBaseName(SrcPath) & ".zip"
    '空のZIPファイル作成
    With .CreateTextFile(DestFilePath, True)
      .Write ChrW(&H50) & ChrW(&H4B) & ChrW(&H5) & ChrW(&H6) & String(18, ChrW(0))
      .Close
    End With
  End With
   
  With CreateObject("Shell.Application")
    With .NameSpace(DestFilePath)
      .CopyHere SrcPath
      While .Items.Count < 1
        DoEvents
      Wend
    End With
  End With
End Sub

'解凍処理
Public Sub UnZipFile(ByVal SrcPath As Variant, _
                     Optional ByVal DestFolderPath As Variant = "")
  'ZIPファイルを解凍
  'SrcPath：元ファイル
  'DestFolderPath：出力先、指定しない場合は元ファイルと同じ場所
  '※出力先に同名ファイルがあった場合はユーザー判断で処理
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(SrcPath) = False Then Exit Sub
    If LCase(.GetExtensionName(SrcPath)) <> "zip" Then Exit Sub
    If IsFolder(DestFolderPath) = False Then
      DestFolderPath = .GetFile(SrcPath).ParentFolder.Path
    End If
  End With
   
  With CreateObject("Shell.Application")
    .NameSpace(DestFolderPath).CopyHere .NameSpace(SrcPath).Items
  End With
End Sub

'フォルダチェック処理
Private Function IsFolder(ByVal SrcPath As String) As Boolean
  IsFolder = CreateObject("Scripting.FileSystemObject").FolderExists(SrcPath)
End Function

'ファイルチェック処理
Private Function IsFile(ByVal SrcPath As String) As Boolean
  IsFile = CreateObject("Scripting.FileSystemObject").FileExists(SrcPath)
End Function

'ファイルパスセパレータ追加処理
Private Function AddPathSeparator(ByVal SrcPath As String) As String
  If Right(SrcPath, 1) <> ChrW(92) Then SrcPath = SrcPath & ChrW(92)
  AddPathSeparator = SrcPath
End Function

Excelでオブジェクトを変数宣言するには
遅延バインディングと事前バインディングの2種類の方法がある。

実装の違い(例として、FileSystemObjectを利用)

• 遅延バインディング

Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")

• 事前バインディング

「ツール」→「参照設定」で
「Microsoft Scripting Runtime」にチェックを付ける。

Dim objFSO As New FileSystemObject
または、
Dim objFSO As FileSystemObject
Set objFSO = New FileSystemObject

一言で言えば、変数宣言の型が
遅延バインディングはObject型
事前バインディングは特定のオブジェクト型
となっている。

遅延バインディング（実行時バインディング）

オブジェクトが Object 型として宣言された変数に代入する場合、
遅延（実行時）にバインディングされる。
この型のオブジェクトは、任意のオブジェクトへの参照を保持できるが、
事前バインディングされたオブジェクトの利点をほとんど持たない。

事前バインディング

特定のオブジェクト型として宣言された変数に代入する場合、
オブジェクトは事前（コンパイル時に）バインディングされる。
事前バインディングされたオブジェクトでは、アプリケーションが実行される前に、
コンパイラによってメモリの割り当てとその他の最適化が実行される。
また、自動クイックヒントが表示されるようになる。

名前の定義は有能だと思うのですが、
参考ブックからコピーすると一緒にコピーされ、
収集つかなくなるためこれで削除します。

Option Explicit

Private Sub NameDefDel()
    Dim Ans, RefStyle, n
    
    Ans = MsgBox("実行しますか？", vbYesNo, "実行確認")
    If Ans = vbNo Then Exit Sub
    
    RefStyle = Application.ReferenceStyle
    
    If RefStyle = xlR1C1 Then
        Application.ReferenceStyle = xlA1
    Else
        Application.ReferenceStyle = xlR1C1
    End If

    For Each n In ActiveWorkbook.Names
        If Not n.Name Like "*!Print_Area" And _
            Not n.Name Like "*!Print_Titles" Then
            n.Delete
        End If
    Next

    Application.ReferenceStyle = RefStyle
    
    MsgBox "完了しました！"
End Sub

選択範囲の取消線を削除します。
納品時の作業で利用することあり。

Sub StrikethroughDel()
    For Each myCell In Selection
        textBefore = myCell.Value
        textAfter = ""
        For i = 1 To Len(textBefore)
            If myCell.Characters(Start:=i, Length:=1).Font.Strikethrough = False Then
                textAfter = textAfter & Mid(textBefore, i, 1)
            End If
        Next i
    Next myCell
End Sub

フォルダ内のJPGファイルをフォルダごとのシートを作成し、
そのシート内に自動で貼り付けします。

Sub JpgPut()

' JpgPut
' JPGファイルを貼り付ける。
' エビデンスが存在する1階層上のフォルダを指定する。(末尾\)
' フォルダ内のJPGファイルは100枚まで。
' 例)
' C:\work\ebi\を指定した場合、
' C:\work\ebi\imgフォルダ内のJPGファイルを貼り付ける。

    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.StatusBar = "処理中・・・"
    
    Dim count As Integer
    count = 0
    Dim folderPath As String ' 環境によって変更すること。
    folderPath = Worksheets(1).Cells(2, 1).Value
    
    Dim fileName As String
    fileName = Dir(folderPath & "\", vbDirectory)
    
    Dim n As Integer
    n = 0
    
    Dim fileNames(100) As String
    Do While fileName <> ""
        fileNames(n) = fileName
        n = n + 1
        fileName = Dir()
    Loop
    
    Dim i As Integer
    Dim j As Integer
    For j = 0 To n
        fileName = fileNames(j)
        If GetAttr(folderPath & "\" & fileName) And vbDirectory Then
            If fileName <> "." And fileName <> ".." And fileName <> "" Then
                i = 0
                Dim newSheet As Worksheet
                Set newSheet = Worksheets.Add()
                newSheet.Move after:=Worksheets(Worksheets.count)
                newSheet.Name = fileName
                
                Dim jpgPath As String
                jpgPath = Dir(folderPath & "\" & fileName & "\" & "*.JPG", vbNormal)
                Do While jpgPath <> ""
                
                    ' 画像の高さに合わせて「45」の数値を変更すること。
                    newSheet.Cells(i * 45 + 1, 1).Value = jpgPath
                    newSheet.Cells(i * 45 + 2, 2).Select
                    
                    ' Excel2010の場合はここから
                    ' 画像を1*1ポイントで貼り付け
                    Set myShape = Worksheets(fileName).Shapes.AddPicture( _
                    fileName:=folderPath & "\" & fileName & "\" & jpgPath, _
                    linkToFile:=False, _
                    saveWithdocument:=True, _
                    Left:=Selection.Left, _
                    Top:=Selection.Top, _
                    Width:=msoTrue, _
                    Height:=msoTrue)
                    ' 画像を元のサイズに変換(Heightの設定は不要かも)
                    ' Withを利用しないとオブジェクトエラーになる。
                    With myShape
                        LockAspecRatio = msoTrue
                        Hieght = 560
                    End With
                    'myShape.LockAspecRatio = msoTrue
                    'myShape.Hieght = 560
                    ' Excel2010の場合はここまで
                    
                    ' Excel2013の場合はここから
                    'Worksheets(fileName).Picutures.Insert fileName:=folderPath & "\" & fileName & "\" & jpgPath
                    ' Excel2013の場合はここまで
                    
                    i = i + 1
                    count = count + 1
                    jpgPath = Dir()
                Loop
                
            End If
        End If
    Next j
    
    Application.StatusBar = count & "個貼り付け完了"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

• 改行ありのテキストファイルを読み取り
  ツールバーの「データ」-「外部データの取り込み」-「テキストファイル」から読み取る方法では、
  項目内に改行があるとずれたり、
  行数が多いと最後まで読み取れないことがある。

  そこで、セル全体を文字列に設定しておき、
  1セルを選択し、適当な文字列を入力する。
  次にそのセルを選択し、ツールバーの「データ」-「区切り位置」を選択する。
  「カンマやタブなどの区切り文字によってフィールドごとに区切られたデータ」を選択する。
  区切り文字に「カンマ」を選択する。
  列のデータ形式に「文字列」を選択する。

  最後にテキストファイルをCTRL+Aで全選択後にコピーし、
  先ほどのセルに貼りつけると、項目内に改行があってもずれずに
  行数が多くても貼りつけることができる。

WBSで日付と曜日を表現することが多いですが、
日付をユーザ定義の「d」を設定。
曜日を数式の「TEXT(日付セル,”aaa”)」にすると使いやすいです。

Javaではクラス名はアッパーキャメルケース(パスカルケース)の形式にします。
メソッド名はローワーキャメルケースの形式にします。

アッパーキャメルケース：FirstExample
ローワーキャメルケース：firstExample

エクセルでA1に「FIRST_EXAMPLE」という文字列があると仮定し、
それをアッパーキャメルケース、ローワーキャメルケースに変換します。

' アッパーキャメルケース
=SUBSTITUTE(PROPER(A1),"_","")
' ローワーキャメルケース
=LOWER(LEFT(A1,1))&MID(SUBSTITUTE(PROPER(A1),"_",""),2,LEN(A1))

Dir関数を用いるため、ネットワーク上の長いファイルパスには未対応です。

Sub Test()

    ' 画面チラつきを防止する。
    Application.ScreenUpdating = False

    ' フォルダパスとファイル名を宣言する。
    Dim strFilePath As String
    Dim strFileNmae As String
         
    ' テキストボックスかセル入力でフォルダを指定させる。
    strFilePath = "C:\Users\test\Desktop\テストディレクトリ"
    
    ' 末尾が\ではない場合、\を追加する。(未実装)
    strFilePath = strFilePath & "\"
    
    ' 指定フォルダ内のファイル名を取得する。
    strFileName = Dir(strFilePath, vbNormal)

    ' 結果シートを変数に設定する。
    Dim resultBookSheet As Worksheet
    Set resultBookSheet = Worksheets("sheet1")
   
    ' 結果シートの行数を宣言する。
    Dim longGyo As Long
    longGyo = 1

    ' 指定フォルダ内のファイルがなくなるまで繰り返す。
    Do While strFileName <> ""

        Dim result As Range
        Dim firstAddress As String

        ' ファイルを開く。
        With Workbooks.Open(Filename:=strFilePath & strFileName)

            ' ファイル内のシート数を取得する。
            Dim sheetCnt As Long
            sheetCnt = .Worksheets.Count

            ' 1シート目からnシート目まで繰り返す。
            Dim i As Long
            For i = 1 To sheetCnt

                Dim shp As Shape
                ' シートからオブジェクトがなくなるまで繰り返す。
                For Each shp In .Worksheets(i).Shapes

                    ' オブジェクトにテキストを書き込める場合
                    ' shp.TextFrameはテキストが書き込めないオブジェクトでエラーが発生してしまう。
                    ' shp.TextFrame2はOffice 2007以降で利用可能だが、
                    ' テキストが書き込めないオブジェクトでもエラーが発生しない。
                    If shp.TextFrame2.HasText = True Then

                        ' 検索文字列がオブジェクト内に存在する場合
                        If InStr(shp.TextFrame2.TextRange.Text, "Excute") > 0 Then
                            resultBookSheet.Cells(longGyo, 1).Value = strFilePath & strFileName
                            resultBookSheet.Cells(longGyo, 2).Value = .Worksheets(i).Name
                            resultBookSheet.Cells(longGyo, 3).Value = "セル(" & shp.TopLeftCell.Address & ") - オブジェクト"
                            resultBookSheet.Cells(longGyo, 4).Value = shp.TextFrame2.TextRange.Text
                            longGyo = longGyo + 1
                        End If
                    End If
                Next
            Next i
            
            ' 保存せずファイルを閉じる。
            .Close SaveChanges:=False
        End With

        ' 次のファイルを取得する。
        strFileName = Dir()
    Loop
        
    ' 画面チラつき防止を解除する。
    Application.ScreenUpdating = True
    
End Sub

• ダブルクリック
  ダブルクリックで開いた場合、数値などは自動判断する。
• テキストファイルで読み取り
  ツールバーの「データ」-「外部データの取り込み」-「テキストファイル」から読み取り、
  区切り文字をカンマに指定し、全項目を文字列として読み取る。
  数値も文字列として読み取るので、先頭が0でも変換しない。
  項目間が”,”の場合、ダブルクォート内のカンマは区切り文字ではなく、
  文字としてのカンマとして扱う。