【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スポットライトの画像が保存されているフォルダのファイルをコピーして格納して置く任意のフォルダ。
【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:="出力先セル(左上の1セル)を選択してください。", Type:=8) 'マージするセルの大きさ(行数) Dim mergeCellRowLength As Integer mergeCellRowLength = Application.InputBox(Prompt:="出力先で1行当たりマージするセル数を入力してください。", 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 '1行内の列を貼り付ける 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
【Excel VBA】分類が縦に書かれているセルに線を引く
会社によってはExcelで書かれた試験仕様書の分類の書き方が、以下のように分類が縦に書かれていたりする。
これに線を引いてしまうマクロを作った。
(枠線の表示を無くすとこんな感じ)
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 '選択範囲を1行ずつ処理する Dim r As Integer For r = selectedRange(1).Row To selectedRange(selectedRange.Count).Row '選択範囲の1行を1列ずつ処理する 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 '選択範囲の2列目以降 '線が引かれていた場合、続けて線を引く 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 '選択範囲の2列目以降 '文字列 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 '選択範囲の2行目以降 If sheet.Cells(r - 1, c).Borders(xlEdgeLeft).LineStyle = xlContinuous Then DoesDrawLineEdgeLeftInCell = True Exit Function End If End If '上記のいずれも該当しなかったので線を引かない DoesDrawLineEdgeLeftInCell = False End Function
テスト
はじめてのはて・・・ぶ