2021-10-03

【Windowsバッチ】Windowsスポットライトの画像を拡張子をbmpに変えながらコピー

echo off

SET SRC=C:\Users\LoginUser\AppData\Local\Packages\Microsoft.Windows.ContentDeliveryManager_cw5n1h2txyewy\LocalState\Assets
SET TMP=C:\Users\LoginUser\Pictures

for /r %SRC% %%i in (*.*) do (
    if not exist %TMP%\%%~nxi.bmp copy %%~i %TMP%\%%~nxi.bmp
)

EXPLORER %TMP%

rem pause
exit

SRC
　Windowsスポットライトの画像が保存されているフォルダ。「LoginUser」はログインしているユーザー名に変えること。
TMP
　Windowsスポットライトの画像が保存されているフォルダのファイルをコピーして格納して置く任意のフォルダ。

2018-01-14

【Excel VBA】結合セルを作りながら貼り付ける

Excel VBA

ソフトウェア開発をしていると、Excel方眼紙というものに出くわすことがある。ありがちな特徴は…
セルが結合されていて、貼り付けに苦労する。
ページ内のタイトルやページ番号をヘッダーとフッター機能を使わず、セルに書かれてあったりするため、改ページまで考慮しないといけなかったりする。

そこで、直接的な解決方法ではないが、コピーしたセルをもとに、貼り付け先に結合セルを作りながら貼り付けるマクロを作成した。
マクロを実行後に作成された結合セルを、手動でExcel方眼紙に対してコピペしていただきたい。

Option Explicit

Public Sub PasteMergedCell()

    Dim src As Range
    Set src = Application.InputBox(Prompt:="変換したいセルを選択してください。", Type:=8)

    Dim dst As Range
    Set dst = Application.InputBox(Prompt:="出力先セル（左上の１セル）を選択してください。", Type:=8)
    
    'マージするセルの大きさ（行数）
    Dim mergeCellRowLength As Integer
    mergeCellRowLength = Application.InputBox(Prompt:="出力先で１行当たりマージするセル数を入力してください。", Type:=1)
    
    'マージするセルの大きさ（列数）
    Dim mergeCellColArray As Variant
    Dim mergeCellColLengthInfo As String
    mergeCellColLengthInfo = Application.InputBox(Prompt:="出力先の列ごとにマージするセル数をカンマ区切りで入力してください。", Type:=2)
    mergeCellColArray = Split(mergeCellColLengthInfo, ",")
        
    Dim srcStartRow As Integer  'コピー開始行
    Dim srcStartCol As Integer  'コピー開始列
    srcStartRow = src.row
    srcStartCol = src.Column
    
    Dim pasteStartRow As Integer    '貼り付け開始行
    Dim pasteStartCol As Integer    '貼り付け開始列
    pasteStartRow = dst.row
    pasteStartCol = dst.Column
        
    Dim pasteTargetRow As Integer   '貼り付け行
    pasteTargetRow = pasteStartRow  '開始行で初期化
    
    Dim pasteTargetCol As Integer   '貼り付け列
    pasteTargetCol = pasteStartCol  '開始列で初期化
    
    '全行ループ
    Dim row As Integer  '現在行
    For row = srcStartRow To srcStartRow + src.Rows.Count - 1
        '変換元を取得
        Dim srcCell As Range
        
        '変換元のある1行の中で最大の行数を取得する
        Dim maxLineCountPerSrcLine As Integer
        maxLineCountPerSrcLine = 0
        
        Dim col As Integer  '現在列
        For col = srcStartCol To srcStartCol + src.Columns.Count - 1
        
            Set srcCell = ActiveSheet.Cells(row, col)   '現在セル

            '変換元の行数を取得
            Dim srcLineCount As Integer
            srcLineCount = UBound(Split(srcCell.Text, vbLf)) + 1    '（セル内改行を取得する）
            
            '貼り付け先の論理行数を算出
            Dim dstLogicalLineCount As Integer
            If srcLineCount < mergeCellRowLength Then
                dstLogicalLineCount = 1
            Else
                dstLogicalLineCount = srcLineCount / mergeCellRowLength
                
                If srcLineCount Mod mergeCellRowLength > 0 Then
                    dstLogicalLineCount = dstLogicalLineCount + 1
                End If
            End If
            
            '貼り付け先の物理行数を算出
            Dim dstPysicalLineCount As Integer
            dstPysicalLineCount = dstLogicalLineCount * mergeCellRowLength
            
            '最大行数を取得する
            If dstPysicalLineCount > maxLineCountPerSrcLine Then
                maxLineCountPerSrcLine = dstPysicalLineCount
            End If
        Next col

        '貼り付け先を作成
        Dim mergeCellColArrayIndex As Integer
        mergeCellColArrayIndex = 0
        
        '１行内の列を貼り付ける
        For col = srcStartCol To srcStartCol + src.Columns.Count - 1
            Set srcCell = ActiveSheet.Cells(row, col)
            
            Dim mergeColLength As Integer
            mergeColLength = mergeCellColArray(mergeCellColArrayIndex)
            
            'セルを結合する
            Dim pasteArea As Range
            Set pasteArea = Range(ActiveSheet.Cells(pasteTargetRow, pasteTargetCol), ActiveSheet.Cells(pasteTargetRow + maxLineCountPerSrcLine - 1, pasteTargetCol + mergeColLength - 1))
            pasteArea.UnMerge   'セルの結合を解除
            
            Application.DisplayAlerts = False  '--- 確認メッセージを非表示
            pasteArea.Merge
            Application.DisplayAlerts = True   '--- 確認メッセージを表示
   
            pasteArea.Value = srcCell.Text
            
            '次の列へ進む
            pasteTargetCol = pasteTargetCol + mergeColLength
            mergeCellColArrayIndex = mergeCellColArrayIndex + 1
        Next col
        
        '貼り付け先を次へ進める
        pasteTargetCol = pasteStartCol
        pasteTargetRow = pasteTargetRow + maxLineCountPerSrcLine
        
    Next row
    
End Sub

2017-10-05

【Excel VBA】分類が縦に書かれているセルに線を引く

Excel VBA

会社によってはExcelで書かれた試験仕様書の分類の書き方が、以下のように分類が縦に書かれていたりする。
f:id:opticient:20171005102504p:plain
これに線を引いてしまうマクロを作った。
f:id:opticient:20171005102627p:plain
（枠線の表示を無くすとこんな感じ）
f:id:opticient:20171005102250p:plain

Option Explicit

'線を引く（分類が縦に書かれている）
'選択しているワークシート（複数可）の選択範囲のセルに線を引きます。
Public Sub DrawLineVerticalClassification()

    '選択しているワークシート毎に処理を繰り返す
    Dim selectedSheet As Worksheet
    For Each selectedSheet In ActiveWindow.SelectedSheets
    
        'Selectionを現在のワークシートの選択範囲にするため、現在のワークシートをアクティブにする
        selectedSheet.Activate
    
        '選択範囲を取得する
        Dim selectedRange As Range
        If TypeName(Selection) <> "Range" Then Exit Sub
        If Selection Is Nothing Then Exit Sub
        Set selectedRange = Selection
    
        '選択範囲を１行ずつ処理する
        Dim r As Integer
        For r = selectedRange(1).Row To selectedRange(selectedRange.Count).Row
        
            '選択範囲の１行を１列ずつ処理する
            Dim c As Integer
            For c = selectedRange(1).Column To selectedRange(selectedRange.Count).Column
            
                '現在のセルを取得する
                Dim cell As Range
                Set cell = selectedSheet.Cells(r, c)
                            
                '上の線を消す
                cell.Borders(xlEdgeTop).LineStyle = xlLineStyleNone
                
                '上の線を引く
                If DoesDrawLineEdgeTopInCell(selectedSheet, selectedRange, r, c) Then
                    cell.Borders(xlEdgeTop).LineStyle = xlContinuous
                End If
                            
                '左の線を消す
                cell.Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
                
                '左の線を引く
                If DoesDrawLineEdgeLeftInCell(selectedSheet, selectedRange, r, c) Then
                    cell.Borders(xlEdgeLeft).LineStyle = xlContinuous
                End If
                
    
                '下に線を引く
                If r = selectedRange(selectedRange.Count).Row Then
                    cell.Borders(xlEdgeBottom).LineStyle = xlContinuous
                End If
            
                '右に線を引く
                If c = selectedRange(selectedRange.Count).Column Then
                    cell.Borders(xlEdgeRight).LineStyle = xlContinuous
                End If
            Next c
        Next r
    Next selectedSheet
End Sub

'セルの上に線を引くか
Private Function DoesDrawLineEdgeTopInCell(ByVal sheet As Worksheet, ByVal selectedRange As Range, ByVal r As Integer, ByVal c As Integer) As Boolean
    
    '今のセルに文字列
    If sheet.Cells(r, c).Text <> "" Then
        DoesDrawLineEdgeTopInCell = True
        Exit Function
    End If
    
    '左隣のセルからの続きである場合
    If c > selectedRange(1).Column Then
        '選択範囲の２列目以降
        
        '線が引かれていた場合、続けて線を引く
        If sheet.Cells(r, c - 1).Borders(xlEdgeTop).LineStyle = xlContinuous Then
            DoesDrawLineEdgeTopInCell = True
            Exit Function
        End If
    End If

    '上記のいずれも該当しなかったので線を引かない
    DoesDrawLineEdgeTopInCell = False
End Function

'セルの左に線を引くか
Private Function DoesDrawLineEdgeLeftInCell(ByVal sheet As Worksheet, ByVal selectedRange As Range, ByVal r As Integer, ByVal c As Integer) As Boolean

    '今のセルに文字列
    If sheet.Cells(r, c).Text <> "" Then
        DoesDrawLineEdgeLeftInCell = True
        Exit Function
    End If

    '左隣のセルからの続きである場合
    If c > selectedRange(1).Column Then
        '選択範囲の２列目以降
        
        '文字列
        If sheet.Cells(r, c - 1).Text <> "" Then
            DoesDrawLineEdgeLeftInCell = False  '線を引かない
            Exit Function
        End If

        '線
        If sheet.Cells(r, c - 1).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone Then
            DoesDrawLineEdgeLeftInCell = False  '線を引かない
            Exit Function
        End If
    End If
    
    '上のセルからの続きである場合
    If r > selectedRange(1).Row Then
        '選択範囲の２行目以降
        
        If sheet.Cells(r - 1, c).Borders(xlEdgeLeft).LineStyle = xlContinuous Then
            DoesDrawLineEdgeLeftInCell = True
            Exit Function
        End If
    End If

    '上記のいずれも該当しなかったので線を引かない
    DoesDrawLineEdgeLeftInCell = False
End Function

2014-08-30

テスト

はじめてのはて・・・ぶ