勉強ブログ

Option Explicit

' 指定したフォルダ内のファイルの一覧を取得
Sub Display_Directory()
Const cnsTitle = "フォルダ内のファイル名一覧取得"
Const cnsDIR = "\*.*"
Dim xlAPP As Application
Dim THIS_WORKBOOK_NAME As String

Dim strPathName As String, vntPathName As Variant
Dim vntSheet As Variant
Dim strFileName As String
Dim line As Long

THIS_WORKBOOK_NAME = ThisWorkbook.Name
'開始行番号
line = 2

Set xlAPP = Application
' InputBoxでフォルダ指定を受ける
vntPathName = xlAPP.InputBox("参照するフォルダ名を入力して下さい。", _
cnsTitle, CurDir)
If VarType(vntPathName) = vbBoolean Then Exit Sub
strPathName = vntPathName
' フォルダの存在確認
If Dir(strPathName, vbDirectory) = "" Then
MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTitle
Exit Sub
End If

' 先頭のファイル名の取得
strFileName = Dir(strPathName & cnsDIR, vbNormal)
' ファイルが見つからなくなるまで繰り返す
Do While strFileName <> ""

' Excelのみ対象
If (InStr(1, strFileName, ".xls", vbTextCompare)) <> 0 And strFileName <> THIS_WORKBOOK_NAME Then


Workbooks.Open Filename:= _
vntPathName & "\" & strFileName

For Each vntSheet In Sheets
'ファイル名を1列目にセット
Workbooks(1).Sheets(1).Cells(line, 1).Value = strFileName
Workbooks(1).Sheets(1).Cells(line, 2).Value = vntSheet.Name
' 行を加算
line = line + 1
Next vntSheet

ActiveWindow.Close

End If

' 次のファイル名を取得
strFileName = Dir()
Loop

Call MsgBox("ファイル・シート名出力が完了しました", vbOKOnly, "終了メッセージ")
End Sub

Sub スクロール位置調整()
Dim ws As Worksheet

For Each ws In Worksheets
ws.Select
Range("A1").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
ActiveWindow.Zoom = 100
Next ws
'Worksheets(1).Range("A1").Select
Worksheets(1).Select
Range("A1").Select
End Sub

'呼び出し元
'内容＝取り消し線のあるセルの値をクリアし、その行を黄色で塗る
'対象＝Range(Cells(1, 1), Cells(1000, 100))
'空白行で取り消し線のあったセルの塗りつぶしは行わない
Function clr_value()
Dim tst As Range

For Each tst In ThisWorkbook.ActiveSheet.Range(Cells(1, 1), Cells(1000, 100))
Call del_strkthr_range(tst)
Next



For Each tst In ThisWorkbook.ActiveSheet.Range(Cells(1, 1), Cells(1000, 100))
tst.Value = del_strkthr_char(tst)
Next

MsgBox "End"
End Function




'呼び出し先
Function del_strkthr_range(cell As Range)
If cell.Font.Strikethrough = True And cell.Value <> "" Then
cell.Value = ""
If WorksheetFunction.CountA(Rows(cell.Row)) = 0 Then
Rows(cell.Row).Interior.ColorIndex = 6
Else
End If
Else
End If


End Function


'呼び出し先
Function del_strkthr_char(cell As Range)
Dim count As Integer
Dim i As Integer
Dim char As Characters
Dim result As String
count = Len(cell.Text)
For i = 1 To count
Set char = cell.Characters(i, 1)
If Not char.Font.Strikethrough Then
result = result + char.Text
End If
Next
del_strkthr_char = result
End Function

概要：ワード内の全ての画面ショット（InlineShapes）の幅を統一するマクロ（縦横比固定のまま）
引数：幅
戻値：なし
備考：なし

Sub change_width(width)

For Each shp In ActiveDocument.InlineShapes
        shp.LockAspectRatio = msoTrue
        shp.width = width
Next

MsgBox "END"

End Sub