エクセル | nujonoa_blog https://nujonoa.com 人生に役立つデータ集 Thu, 20 Apr 2023 03:10:55 +0000 ja hourly 1 https://wordpress.org/?v=6.8.3 https://nujonoa.com/wp-content/uploads/2019/04/cropped-DSC00976-e1554456145409-32x32.jpg エクセル | nujonoa_blog https://nujonoa.com 32 32 条件付き書式を一括で消す場合は、「Cells.FormatConditions.Delete」 https://nujonoa.com/cells-formatconditions-delete/ https://nujonoa.com/cells-formatconditions-delete/#respond Thu, 20 Apr 2023 03:09:47 +0000 https://nujonoa.com/?p=23852

自分の忘備録です。

条件付き書式を一括で消す場合は、「Cells.FormatConditions.Delete」

条件付き書式を一括で消す方法は、

イミディエントウインドで、


Cells.FormatConditions.Delete


を打ち込んでenterになります。

実は動作が重い条件付き書式

実はファイルが重くなってしまっている原因が、条件付き書式であることが多々ありますので、
一括で削除してどれくらいファイルの動きが軽くなるか、試してみるといいと思います！！！

]]> https://nujonoa.com/cells-formatconditions-delete/feed/ 0 【VBA】Excelにフォルダ内の画像一覧を作る方法 https://nujonoa.com/how-to-make-a-list-of-images-in-a-folder-in-vbaexcel/ https://nujonoa.com/how-to-make-a-list-of-images-in-a-folder-in-vbaexcel/#respond Thu, 21 Apr 2022 14:08:06 +0000 http://nujonoa.com/?p=11120 忘備録です。

【VBA】Excelにフォルダ内の画像一覧を作る方法

フォルダの画像を一気に張り付けて、画像一覧を作成するプログラムです。

画像を確認し、一気に名前を変更したいときなどにお使いいただけるかと思います。

Sub JIKKOU2()

    Dim RowN As Integer
    
    ''エクセルシート上で選択した範囲内の全ての図形を削除する

    Set select_range = Range(Cells(6, 1), Cells(10000, 4))
    select_range.ClearContents
    If ActiveSheet.Shapes.Count > 2 Then
        For i = ActiveSheet.Shapes.Count To 1 Step -1
            With ActiveSheet.Shapes(i)
                Set shp_rng = Range(.TopLeftCell, .BottomRightCell)
                If Not Intersect(shp_rng, select_range) Is Nothing Then
                    ActiveSheet.Shapes(i).Delete
                End If
            End With
        Next i
    End If
        
    Application.ScreenUpdating = False '画面更新をOFF
    Application.Calculation = xlManual '自動計算をOFF
    Application.EnableEvents = False 'イベントをOFF
    
    LASTY = Cells(Rows.Count, 2).End(xlUp).Row '1を任意に替える
        
    Call searchPic(Cells(3, 4), 6) '←検索したいフォルダを指定する。ColNは張り付け始める位置。
         
    Application.ScreenUpdating = True '画面更新をON
    Application.Calculation = xlAutomatic '自動計算をON
    Application.EnableEvents = True 'イベントをON
     
End Sub
  
Sub searchPic(PATH As String, ColN As Integer)
    Dim buf As String, childf As Object
 
'フォルダ内全部
    buf = Dir(PATH & "\*.png")
   
    Do While buf <> ""
     
        Cells(ColN, 1).Value = ParentDirName(PATH)
        Cells(ColN, 2).Value = buf
        Cells(ColN, 3).Activate
       '名前が一致したら実行するように指示。
       
        myFileName = PATH & "\" & buf
         
        '--(1) 選択位置に画像ファイルを挿入し、変数myShapeに格納
        Set myShape = ActiveSheet.Shapes.AddPicture( _
              Filename:=myFileName, _
              LinkToFile:=True, _
              SaveWithDocument:=False, _
              Left:=Selection.Left + 1, _
              Top:=Selection.Top + 1, _
              Width:=0, _
              Height:=0)
              
        '--(2) 挿入した画像に対して元画像と同じ高さ・幅にする
        With myShape
            .ScaleHeight 1.5, msoTrue
            .ScaleWidth 1.5, msoTrue
        End With
            
        ColN = ColN + 1
        
       
       '次のファイル
           buf = Dir()
    Loop
     
    '子フォルダも同様に、subFolderを実行する。
    With CreateObject("Scripting.FileSystemObject")
        For Each childf In .GetFolder(PATH).SubFolders
            Call searchKatashiki(childf.PATH, ColN)
        Next
    End With
     
End Sub


Function ParentDirName(PATH As String) As String

    ParentDirName = Left(PATH, InStrRev(PATH, "\") - 1)
    ParentDirName = Mid(ParentDirName, InStrRev(ParentDirName, "\") + 1)
    


'  With ThisWorkbook
'    ParentDirName = Left(ParentDirName, InStrRev(ParentDirName, "\") - 1)
'  End With


End Function
]]> https://nujonoa.com/how-to-make-a-list-of-images-in-a-folder-in-vbaexcel/feed/ 0 【VBA】指定したフォルダのファイル一覧を取得、名前を一括で変更する方法 https://nujonoa.com/batch-conversion-of-names-in-folders/ https://nujonoa.com/batch-conversion-of-names-in-folders/#respond Thu, 07 Apr 2022 03:00:00 +0000 http://nujonoa.com/?p=11104 名前一括変換の忘備録です。

【VBA】指定したフォルダのファイル一覧とリンクを取得

まずは、指定したフォルダのファイル一覧と、そのリンクを取得するプログラムで、
ファイル一覧を取得します。

Sub ファイル一覧()
Dim buf As String
Dim i As Long
Dim Path As String
 
'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    Path = .SelectedItems(1)
    End With
 
'エクセルのみ抽出
    buf = Dir(Path & "\*.xlsx")
    
    Cells(2, 3).Value = "フォルダ⇒"
    Cells(2, 4).Value = "=HYPERLINK(""" & Path & """,""リンク"")"
    Cells(2, 5) = Path
     
     
'CELL B2からスタート。
     
     
   Cells(4, 2) = "No"
   Cells(4, 3) = "ファイル名"
   Cells(4, 4) = "リンク"
   Cells(4, 5) = "パス"
   Cells(4, 6) = "名前を変更したい場合↓"
      
     i = 4
     
    Do While buf <> ""
        i = i + 1
'No
        Cells(i, 2) = i - 4
'ファイル名
        Cells(i, 3) = buf
'リンクを
        LINK = Path & "\" & buf
        Cells(i, 4).Value = "=HYPERLINK(""" & LINK & """,""リンク"")"
        Cells(i, 5).Value = LINK
 
        buf = Dir()
    Loop
    
    Columns(5).ShrinkToFit = True

    
 
End Sub

そのあと、F列に変更したい名前を入力し、
下記プログラムを実行することで、名前を変更します。
(.xlsxなどを入力しなくても、同様の拡張子をつけるようにif分岐させています)

Sub ファイル名前変更()
Dim buf As String
Dim i As Long
Dim Path As String
 
'フォルダの選択
    Path = Cells(2, 5)
    
    LASTY = Cells(Rows.Count, 3).End(xlUp).Row

    For i = 5 To LASTY
    
        If Cells(i, 6) <> "" Then
        
            OldName = Path & "\" & Cells(i, 3)

            '拡張子有り無しで分岐
            If InStr(1, Cells(i, 6), ".") > 0 Then
            
                NewName = Path & "\" & Cells(i, 6)
            
            Else
            
                KAKUCHOUSHI = Mid(Cells(i, 3), InStr(1, Cells(i, 3), "."))
                NewName = Path & "\" & Cells(i, 6) & KAKUCHOUSHI
            
            End If
        
            '名前の変更
            Name OldName As NewName
            Cells(i, 7) = "完了"
        
        End If
    
    Next
 
End Sub

]]> https://nujonoa.com/batch-conversion-of-names-in-folders/feed/ 0 【VBA】指定したフォルダのファイル一覧とリンクを取得 https://nujonoa.com/vba-get-file-list-and-link-of-specified-folder/ https://nujonoa.com/vba-get-file-list-and-link-of-specified-folder/#respond Mon, 04 Apr 2022 13:13:27 +0000 http://nujonoa.com/?p=11095 忘備録

【VBA】指定したフォルダのファイル一覧とリンクを取得

指定したフォルダの一覧と、そのリンクを取得するプログラムになります。

Sub ファイル一覧()
Dim buf As String
Dim i As Long
Dim Path As String

'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    Path = .SelectedItems(1)
    End With

'エクセルのみ抽出
    buf = Dir(Path & "\*.xlsx")

'CELL B2からスタート。    
     i = 1
    Do While buf <> ""
        i = i + 1
'No
        Cells(i, 2) = i
'ファイル名
        Cells(i, 3) = buf
'リンクを
        LINK = Path & "\" & buf
        Cells(i, 4).Value = "=HYPERLINK(""" & LINK & """,""リンク"")"

        buf = Dir()
    Loop

End Sub
]]> https://nujonoa.com/vba-get-file-list-and-link-of-specified-folder/feed/ 0 ウォーターフォールグラフのエクセルフォーマット https://nujonoa.com/template-of-waterfall-graph/ https://nujonoa.com/template-of-waterfall-graph/#respond Wed, 06 Oct 2021 04:28:41 +0000 http://nujonoa.com/?p=9725
  1. 階段グラフ(ウォーターフォール)のフォーマット
  2. 使用例はこちら
  3. 使い方

階段グラフ(ウォーターフォール)のフォーマット

決算資料などでよくある、

「階段グラフ」

ですが、これを使えると、前回からの変更点などを視覚化することができ、
非常に便利です。

最新版のエクセルでは、グラフの一つとして作れるようになっているようですが、
昔のエクセルなどでも使えるようにテンプレートを作成しましたので、

もしよかったら使って頂けたら幸いです。

使用例はこちら

使用例は、こちらの通りで、
値を入力することで、
・ベースとなる棒
・プラス、マイナスとなる棒
が表示され、下記の通り変化を記録できます。
(下の場合は、給料の額面から手取りまでの差になっています)

手取りの変化を階段グラフで確認。ウォーターフォールグラフの例
手取りの変化を階段グラフで確認
ウォーターフォールグラフのテンプレートダウンロード

使い方

使い方は、上部にある、
・ベースとなる値
・コスト増
・コスト減
を入力して頂ければ、下記の通りグラフが完成します。

階段グラフの使い方

ぜひ活用してみてください。

ウォーターフォールグラフのテンプレートダウンロード
]]> https://nujonoa.com/template-of-waterfall-graph/feed/ 0 VBA→VBSの変換！VBS→VBAの起動を！ https://nujonoa.com/vba-to-vbs/ https://nujonoa.com/vba-to-vbs/#respond Wed, 18 Aug 2021 13:43:00 +0000 http://nujonoa.com/?p=9668
  1. VBA→VBSの変換！VBS→VBAの起動を！
  2. コード
  3. コードの説明
  4. 活用方法

VBA→VBSの変換！VBS→VBAの起動を！

VBAでファイル名の変更などを行った場合、
これを他の人にも展開したいなと考えることがあるかと思います。

そこでお勧めするのが、VBSを用いる方法です。

コード

Dim ExcelApp
Dim ExcelBook
Dim FilePath

FilePath = "G:\共有ドライブ\TEST_FOLDER\utf-8_to_shiftjis.xlsm" '←ここを変更
VBA_P = "TEST1" '←ここを変更

Set ExcelApp=CreateObject("Excel.Application")
Set ExcelBook= ExcelApp.Workbooks.Open(FilePath)
ExcelApp.ActiveWorkbook.Worksheets(1).select

ExcelApp.visible = false

ExcelApp.Run VBA_P

ExcelBook.Close True
ExcelApp.quit

Set ExcelApp=Nothing
Set ExcelBook=Nothing

コードの説明

コードは非常に簡単で、

Set ExcelApp=CreateObject("Excel.Application")
Set ExcelBook= ExcelApp.Workbooks.Open(FilePath)

でエクセルを立ち上げて

ExcelApp.ActiveWorkbook.Worksheets(1).select

でワークシートを指定して

ExcelApp.visible = false

ExcelApp.Run VBA_P

Excelを見えないように、マクロをはしらせ

ExcelBook.Close True
ExcelApp.quit

Set ExcelApp=Nothing
Set ExcelBook=Nothing

これで、エクセルを閉じております。

活用方法

活用方法としては、

1ヶ月、1週間毎に繰り返し行う集計、更新作業などを、
ワンクリックで更新することができるようになります。

また、

ExcelApp.visible = True '←F
'コメントに変換　ExcelBook.Close True

で、エクセルファイルをそのまま立ち上げたまま、
チェック作業に入ることも可能です。

]]> https://nujonoa.com/vba-to-vbs/feed/ 0 【VBA】ファイルを立ち上げずに、セルの情報を抜き出す方法 https://nujonoa.com/how-to-extract-information-without-launching-a-file/ https://nujonoa.com/how-to-extract-information-without-launching-a-file/#respond Thu, 04 Feb 2021 14:07:43 +0000 http://nujonoa.com/?p=8763
  1. 【VBA】ファイルを立ち上げずに、エクセルの情報を抜き出す方法
  2. プログラム紹介
  3. プログラムの説明
  4. まとめ

【VBA】ファイルを立ち上げずに、エクセルの情報を抜き出す方法

エクセルで他のシートからセルの情報を持ってこようとすると、
ブックを立ち上げて、情報をコピーして、閉じてを繰り返し行う必要があります。

が、そんなことやっていたら日が暮れてしまいますよね。。

そこで今回は、ファイルを立ち上げずに、下記のように

・特定のフォルダ内の
・全ブックの
・全シートの
・特定のセルの情報
を持ってくる方法を紹介したいと思います。

フォルダ内の全ファイル全シートの情報を抜き出す。

プログラム紹介

プログラムを動かす前に、

①VBAの編集画面「ツール→参照」で、
Microsoft ActiveX Data Objects 2.8 Library
を追加して下さい。
②フォルダパスを検索したいパスに設定してください。
③「任意のセルに変更」の箇所を思い通りに変更ください。

※ダブルクリックでコピーできます。

Sub JIKKOU()
 
        Call DBMacro("C:\Users\bluei\OneDrive\ドキュメント\blog\fp") '←検索したいフォルダを指定する。
     
End Sub

Sub DBMacro(Path As String)
 
  Application.ScreenUpdating = False
 
'    Application.Calculation = xlCalculationManual '自動計算停止(手動計算)
 
    Dim objCn As New ADODB.Connection
    Dim objRS As ADODB.Recordset
    Dim sSheet As String
    Dim i      As Long
     
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set cf = fso.GetFolder(Path)
     
    Z = 2
     
    Cells(Z, 1) = "ファイルへのパス"
    Cells(Z, 2) = "ファイル名"
    Cells(Z, 3) = "シート名"
    Cells(Z, 4) = "計算用"
    Cells(Z, 5) = "フォルダパス"
    Cells(Z, 6) = "シートへのリンク"
    Cells(Z, 7) = "ここからセルの値⇒⇒"
    Z = Z + 1
     
    For Each sFile In cf.Files
  
    If sFile = "False" Then
        Exit Sub
    End If
     
    If sFile.Name Like "*.xls*" Then
     
    Else
        GoTo Continue
    End If
   
'db関数を使用。
    With objCn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0"
        .Open sFile
        Set objRS = .OpenSchema(ADODB.adSchemaTables)
    End With
 
’シート名を取り出す作業
    Do Until objRS.EOF
        sSheet = objRS.Fields("TABLE_NAME").Value
        If Right(sSheet, 1) = "$" Or Right(sSheet, 2) = "$'" Then
            If Right(sSheet, 1) = "$" Then
                sSheet = Left(sSheet, Len(sSheet) - 1)
            End If
            If Right(sSheet, 2) = "$'" Then
                sSheet = Left(sSheet, Len(sSheet) - 2)
            End If
            If Left(sSheet, 1) = "'" Then
                sSheet = Mid(sSheet, 2)
            End If
            sSheet = Replace(sSheet, "''", "'")
   
'情報を張っていく。
     Application.DisplayAlerts = False
             
            Cells(Z, 1) = sFile.Path
            Cells(Z, 2) = sFile.Name
            Cells(Z, 3) = "'" & Replace(sSheet, "#", ".")
             
            Cells(Z, 4) = InStrRev(Cells(Z, 1), "\")
            Cells(Z, 5) = Left(Cells(Z, 1), Cells(Z, 4))
            CELLPASS = "'" & Cells(Z, 5) & "[" & Cells(Z, 2) & "]" & Cells(Z, 3) & "'!"
            Cells(Z, 6) = "=HYPERLINK(A" & Z & "&""#""&C" & Z & "&""!A1"",""リンク"")"
             
            Cells(Z, 7) = "=" & CELLPASS & "F6"  '任意のセルに変更
            Cells(Z, 8) = "=" & CELLPASS & "Y6"  '任意のセルに変更
            Cells(Z, 9) = "=" & CELLPASS & "M9"  '任意のセルに変更
            Cells(Z, 10) = "=" & CELLPASS & "M15"  '任意のセルに変更
            Cells(Z, 11) = "=" & CELLPASS & "E19"  '任意のセルに変更
            Cells(Z, 12) = "=" & CELLPASS & "B26"  '任意のセルに変更
            Cells(Z, 13) = "=" & CELLPASS & "I26"  '任意のセルに変更
            Cells(Z, 14) = "=" & CELLPASS & "P26"  '任意のセルに変更
            Cells(Z, 15) = "=" & CELLPASS & "B28"  '任意のセルに変更

 
            DoEvents  '重すぎるのでフリーズしないように入れる。
 
'シートをリンクさせないバージョン↓
'            Cells(Z, 8).Value = ExecuteExcel4Macro("'" & Cells(Z, 5) & "[" & Cells(Z, 2) & "]" & Cells(Z, 3) & "'!R26C2")
             
             
        Application.DisplayAlerts = True
             
             
            Z = Z + 1
        End If
        objRS.MoveNext
    Loop
    objRS.Close
    objCn.Close
    Set objRS = Nothing
    Set objCn = Nothing
     
        Application.StatusBar = Z
     
Continue:
    Next

    '子フォルダも同様に、subFolderを実行する。
    With CreateObject("Scripting.FileSystemObject")
        For Each childf In .GetFolder(Path).SubFolders
            Call DBMacro(childf.Path)
        Next
    End With
     
    Application.Calculation = xlCalculationAutomatic '自動計算開始
    
    Range(Cells(1, 1), Cells(Z, 30)).Formula = Range(Cells(1, 1), Cells(Z, 30)).Formula
    
  Application.ScreenUpdating = True
     
End Sub

プログラムの説明

ADOを使って、エクセルをDBとみなして、
各ファイルのシートをすべてとってきています。

'db関数を使用。
    With objCn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0"
        .Open sFile
        Set objRS = .OpenSchema(ADODB.adSchemaTables)
    End With
 
’シート名を取り出す作業
    Do Until objRS.EOF
        sSheet = objRS.Fields("TABLE_NAME").Value
        If Right(sSheet, 1) = "$" Or Right(sSheet, 2) = "$'" Then
            If Right(sSheet, 1) = "$" Then
                sSheet = Left(sSheet, Len(sSheet) - 1)
            End If
            If Right(sSheet, 2) = "$'" Then
                sSheet = Left(sSheet, Len(sSheet) - 2)
            End If
            If Left(sSheet, 1) = "'" Then
                sSheet = Mid(sSheet, 2)
            End If
            sSheet = Replace(sSheet, "''", "'")

その情報を使って、
・そのブックにリンクを作っていきます。
【＝'パス名[ブック名]シート名'セル名】
例)='C:\Users\bluei\OneDrive\ドキュメント\blog\fp[(201912)簡易FP.xlsx]→'!F6】

他のファイルで↓の表示が出ると、かなり萎えますが、今回の場合は、これを思う存分行うようにしています。

安全ではない可能性のある外部ソースへのリンクが

そのまま数式は残してありますが、最後にコピーして値貼り付けをすれば、
このリンクは削除できますので、変に重たいファイルになることを防ぐことも可能です。

まとめ

暗黙知を形式知にしたり、情報の共有を図るために、

・何かしらのフォーマットにある程度のルールにのっとったファイル

を作っていくことがあると思いますが、
残念ながらそれがうまく活用されることが少ないように感じます。

そのハードルを下げるためにも、誰もが使っているエクセルで、
DBを作ることに意味はあると思います。

是非検討してみてください！！

]]> https://nujonoa.com/how-to-extract-information-without-launching-a-file/feed/ 0 【エクセルDB】フォルダ内の全ファイル全シートのセルの情報を書き出す。 https://nujonoa.com/extract-cell-information-of-all-files-and-all-sheets/ https://nujonoa.com/extract-cell-information-of-all-files-and-all-sheets/#respond Sat, 23 Jan 2021 13:53:11 +0000 http://nujonoa.com/?p=8184
  1. 【エクセルDB】フォルダ内の全ファイル全シートの情報を書き出す。
  2. プログラム紹介
  3. プログラムの説明
  4. まとめ

【エクセルDB】フォルダ内の全ファイル全シートの情報を書き出す。

エクセルは時代遅れ、、、といわれながらも、
社内外のやり取りはエクセルで行われるのが主ですし、
これからもそれがどっと変わることはないでしょう。
※スプレッドシートはありかなと思うのですが…
　結局なんやかんや表計算ソフトは便利です。

そこで、今回はエクセルデータベースをVBAで無理やり作ってみました。

出来ることは、下記画像の通り、
対象のフォルダ内のエクセルシートの
・ファイルのパス
・エクセルのファイル名
・エクセルのシート名
・そのシートへのリンク
・そのシートの対象のセルの値を読み込む。

フォルダ内の全ファイル全シートの情報を抜き出す。

というプログラムです。

フォルダと、セルの値だけ変えてもらえればすぐに使えますので、
ぜひ参考にしてみてください！！！

プログラム紹介

プログラムを動かす前に、

①VBAの編集画面「ツール→参照」で、
Microsoft ActiveX Data Objects 2.8 Library
を追加して下さい。
②フォルダパスを検索したいパスに設定してください。
③「任意のセルに変更」の箇所を思い通りに変更ください。

それが出来たら実行してください。

Sub DBMacro(Path As String)
 
  Application.ScreenUpdating = False
 
'    Application.Calculation = xlCalculationManual '自動計算停止(手動計算)
 
    Dim objCn As New ADODB.Connection
    Dim objRS As ADODB.Recordset
    Dim sSheet As String
    Dim i      As Long
     
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set cf = fso.GetFolder(Path)
     
    Z = 2
     
    Cells(Z, 1) = "ファイルへのパス"
    Cells(Z, 2) = "ファイル名"
    Cells(Z, 3) = "シート名"
    Cells(Z, 4) = "計算用"
    Cells(Z, 5) = "フォルダパス"
    Cells(Z, 6) = "シートへのリンク"
    Cells(Z, 7) = "ここからセルの値⇒⇒"
    Z = Z + 1
     
     
     
    '直下
     
    For Each sFile In cf.Files
     
  
    If sFile = "False" Then
        Exit Sub
    End If
     
    If sFile.Name Like "*.xls*" Then
     
    Else
        GoTo Continue
    End If
   
    With objCn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0"
        .Open sFile
        Set objRS = .OpenSchema(ADODB.adSchemaTables)
    End With
 
    Do Until objRS.EOF
        sSheet = objRS.Fields("TABLE_NAME").Value
        If Right(sSheet, 1) = "$" Or Right(sSheet, 2) = "$'" Then
            If Right(sSheet, 1) = "$" Then
                sSheet = Left(sSheet, Len(sSheet) - 1)
            End If
            If Right(sSheet, 2) = "$'" Then
                sSheet = Left(sSheet, Len(sSheet) - 2)
            End If
            If Left(sSheet, 1) = "'" Then
                sSheet = Mid(sSheet, 2)
            End If
            sSheet = Replace(sSheet, "''", "'")
        Application.DisplayAlerts = False
             
            Cells(Z, 1) = sFile.Path
            Cells(Z, 2) = sFile.Name
            Cells(Z, 3) = "'" & Replace(sSheet, "#", ".")
             
            Cells(Z, 4) = InStrRev(Cells(Z, 1), "\")
            Cells(Z, 5) = Left(Cells(Z, 1), Cells(Z, 4))
            CELLPASS = "'" & Cells(Z, 5) & "[" & Cells(Z, 2) & "]" & Cells(Z, 3) & "'!"
            Cells(Z, 6) = "=HYPERLINK(A" & Z & "&""#""&C" & Z & "&""!A1"",""リンク"")"
             
            Cells(Z, 7) = "=" & CELLPASS & "F6"  '任意のセルに変更
            Cells(Z, 8) = "=" & CELLPASS & "Y6"  '任意のセルに変更
            Cells(Z, 9) = "=" & CELLPASS & "M9"  '任意のセルに変更
            Cells(Z, 10) = "=" & CELLPASS & "M15"  '任意のセルに変更
            Cells(Z, 11) = "=" & CELLPASS & "E19"  '任意のセルに変更
            Cells(Z, 12) = "=" & CELLPASS & "B26"  '任意のセルに変更
            Cells(Z, 13) = "=" & CELLPASS & "I26"  '任意のセルに変更
            Cells(Z, 14) = "=" & CELLPASS & "P26"  '任意のセルに変更
            Cells(Z, 15) = "=" & CELLPASS & "B28"  '任意のセルに変更
            Cells(Z, 16) = "=" & CELLPASS & "I28"  '任意のセルに変更
            Cells(Z, 17) = "=" & CELLPASS & "N28"  '任意のセルに変更
            Cells(Z, 18) = "=" & CELLPASS & "I29"  '任意のセルに変更
            Cells(Z, 19) = "=" & CELLPASS & "P29"  '任意のセルに変更
            Cells(Z, 20) = "=" & CELLPASS & "W26"  '任意のセルに変更
            Cells(Z, 21) = "=" & CELLPASS & "AD26"  '任意のセルに変更
            Cells(Z, 22) = "=" & CELLPASS & "AK26"  '任意のセルに変更
            Cells(Z, 23) = "=" & CELLPASS & "W28"  '任意のセルに変更
            Cells(Z, 24) = "=" & CELLPASS & "AD28"  '任意のセルに変更
            Cells(Z, 25) = "=" & CELLPASS & "AI28"  '任意のセルに変更
            Cells(Z, 26) = "=" & CELLPASS & "AD29"  '任意のセルに変更
            Cells(Z, 27) = "=" & CELLPASS & "AK29"  '任意のセルに変更
 
            DoEvents  '重すぎるのでフリーズしないように入れる。
 
'シートをリンクさせないバージョン↓
'            Cells(Z, 8).Value = ExecuteExcel4Macro("'" & Cells(Z, 5) & "[" & Cells(Z, 2) & "]" & Cells(Z, 3) & "'!R26C2")
             
             
        Application.DisplayAlerts = True
             
             
            Z = Z + 1
        End If
        objRS.MoveNext
    Loop
    objRS.Close
    objCn.Close
    Set objRS = Nothing
    Set objCn = Nothing
     
        Application.StatusBar = Z
     
Continue:
    Next

    '子フォルダも同様に、subFolderを実行する。
    With CreateObject("Scripting.FileSystemObject")
        For Each childf In .GetFolder(Path).SubFolders
            Call DBMacro(childf.Path)
        Next
    End With
     
    Application.Calculation = xlCalculationAutomatic '自動計算開始
    
    
    
    Range(Cells(1, 1), Cells(Z, 30)).Formula = Range(Cells(1, 1), Cells(Z, 30)).Formula
    
  Application.ScreenUpdating = True
     
End Sub

Sub JIKKOU()
 
        Call DBMacro("C:\Users\bluei\OneDrive\ドキュメント\blog\fp") '←検索したいフォルダを指定する。
     
End Sub

プログラムの説明

長すぎるので、説明は端折りますが、

・ファイルを検索して、
・ファイルがエクセルの場合、その中のシートを全部読み取りハイパーリンクを作成がてら、
・そのシートの特定のセルへ【='C:\Users\bluei\OneDrive\ドキュメント\blog\fp[(201912)簡易FP.xlsx]→'!F6】みたいな外部リンクの数式をじゃんじゃん作っていく。

イメージです。

よくある悪者

安全ではない可能性のある外部ソースへのリンクが

を逆に存分に使ってやろうという感じになります。
そのまま数式は残してありますが、最後にコピーして値貼り付けをすれば、
このリンクは削除できますので、変に重たいファイルになることを防ぐことも可能です。

まとめ

結構苦労してたどり着いたプログラムなので、
かわいがってやってください。

何か要望などあれば、コメントへどうぞ！

]]> https://nujonoa.com/extract-cell-information-of-all-files-and-all-sheets/feed/ 0 【エクセル】条件(未満、以上)が多い場合にIF文を使わずVLOOKUPで代用する方法。 https://nujonoa.com/calculation-of-multiple-thresholds/ https://nujonoa.com/calculation-of-multiple-thresholds/#respond Fri, 27 Nov 2020 11:00:36 +0000 http://nujonoa.com/?p=7771
  1. 【エクセル】条件(未満、以上)が多い場合にIF文を使わずVLOOKUPで代用する方法。
  2. VLOOKUPの1を使用する。
  3. 数式の説明
    1. 注意点

【エクセル】条件(未満、以上)が多い場合にIF文を使わずVLOOKUPで代用する方法。

採点結果をまとめる際に、あるしきい値毎に、

30点未満は不合格
60点未満は追試
それ以外は合格

と判断していく際には一般的にIF文が使われると思います。
が、

20点未満は　1
40点未満は　2
60点未満は　3
80点未満は　4
80点以上は　5

と、条件が多くなってくると

=IF(A1<20,1,IF(A1<40,2,IF(A1<60,3,IF(A1<80,4,5))))

と非常に式が複雑になります。IFSを用いても、

=IFS(A1<20, 1, A1<40, 2,A1<60, 3,A1<80, 4,A1<=100, 5)

と、あまり変わりませんね…

そこで今回は、VLOOKUPを用いて簡単に記載していきたいと思います。

VLOOKUPの1を使用する。

今回紹介する関数は、
・VLOOKUP
です。

エクセルをよく使う人にとって、
VLOOKUPなんていつも使っているよ！！と思われる方が多数かと思いますが、

＝VLOOKUP(検査値,範囲,列,1)

と、最後の数字を「1」で、近時値検索を使っている人はごく少数なのではないでしょうか？

今回は、「１」を使ったVLOOKUPの性質を利用して、
下記画像のように判定をしています。
・0~20点の人は1
・20点～40点の人は2
と、きちんと判定されていることがわかると思います。

数式の説明

今回は、おなじみの関数VLOOKUPを用いて、
条件検索を行っています。

VLOOKUPの4項目、条件式を「1」と記述すると、

＝VLOOKUP(検査値,範囲,列,1)

「検査値以下の数値で一番近い数字」

を検索することができます。

例えば、先ほどの画像で、データ１の得点は、64点です。
それに対して判定表は20点ごとに区分されています。

VLOOKUP(,,,1)を使うと検査値以下の数値で一番近い数字を検索してくれますので、
0,20,40,60,80のなかで、64に一致するとみなされるのは、
60となり、その行の判定結果4が返されていることがわかります。

同様に、79点の場合、0,20,40,60,80で一番近い数字は80になりますが、
あくまで、検査値以下の数値で一番近い数字を拾ってきますので、
一致したとみなされるのは60となります。

注意点

点数を小さい順から書いていく必要があり、
IF文では点未満は○○と記載していくのに対し、
この方式では、点以上と記述していく必要があります。

IF文　　　　　　　　　VLOOKUP型
・20点未満は　1　→　00以上？？以下は　1
・40点未満は　2　→　20以上？？以下は　2
・60点未満は　3　→　40以上？？以下は　3
・80点未満は　4　→　60以上？？以下は　4
・80点以上は　5　→　80以上？？以下は　5

「０点以上では、どの人も当てはまってしまうので、
一つ下のセルを見ないと、上限がわからない。」

と、少々なれるまでに手間がかかるかと思いますが、
非常にきれいにまとまりますし、条件変更が簡単ですのでぜひ使ってみてください！

]]> https://nujonoa.com/calculation-of-multiple-thresholds/feed/ 0 【エクセル】上位n個の合計値を1セルで計算する方法！ https://nujonoa.com/calculate-the-total-value-of-the-top-n-points/ https://nujonoa.com/calculate-the-total-value-of-the-top-n-points/#respond Sun, 22 Nov 2020 14:18:00 +0000 http://nujonoa.com/?p=7653
  1. 上位n個の合計値を計算する方法！
  2. 数式紹介
  3. 数式の説明

上位n個の合計値を計算する方法！

二八の法則といわれるように、
物事は、

上位2割のものの合計が8割を占める

という現象がよく起こります。
そこで、上位n個の合計値を確認し割合を確認することで
データの目の付け所を知ることができます。

そこで今回亜H、上位n個を関数で計算する方法を紹介したいとも思います。

数式紹介

今回紹介する数式は、
・SUMPRODUT
・ROWS
・INDIRECT
を用いて、

=SUMPRODUCT(LARGE(データ範囲,ROW(INDIRECT("1:n"))))

実際の使用例
=SUMPRODUCT(LARGE($C$3:$C$10,ROW(INDIRECT("1:3"))))

と記述します。

計算結果は下記の通り、
・上位1位までの合計が、10
・上位2位までの合計が、18=10+8
・上位3位までの合計が、24=10+8+6
と、狙った通り計算できていることが分かります。

数式の説明

今回の肝となっている関数はLARGE関数です。

LARGE関数は

= LARGE(data ,n ) // n番目に大きい

のように、使用し、n番目に大きい数字を検索することができます。

今回はそれにSUMPRODUCT関数を組み合わせて上位n点の合計を表現しています。

この数式にたどり着くイメージは、

①簡単に記述すると、
= LARGE(data ,１) +LARGE(data ,2) +LARGE(data ,3) +・・・＋LARGE(data ,n)

②上記の式をSUMPRODUCTで表現すると下記のように書くことができる。
=SUMPRODUCT(LARGE(data,{1,2,3,…n})

③配列のn数が多くなると記述できなくなるので、ROWを用いて表現。
＝SUMPRODUCT(LARGE(data,ROW(INDIRECT("1:N")))

という流れになるかと思います。

ROW(INDIRECT("1:N")が理解しにくいかと思いますが、
実際セルに入力すると、下記のように1～10までの配列が作成されることが分かると思います。

]]> https://nujonoa.com/calculate-the-total-value-of-the-top-n-points/feed/ 0