お知らせ

20210819

Option Explicit

‘エクスポートSQL
Private Sub Command_Click()

Dim Dbs         As DAO.Database
Dim Qdf         As DAO.QueryDef
Dim FileName    As String
Dim FNum        As Integer
Dim stSQL       As String
Dim ret         As Double

' データベースセット
Set Dbs = CurrentDb
'Set Dbs = DAO.OpenDatabase("c:\test.mdb") ' DBの指定がある場合

' ファイルを開く
FNum = FreeFile
FileName = Mid(Dbs.Name, InStrRev(Dbs.Name, "\") + 1)
FileName = Left(FileName, InStrRev(FileName, ".") - 1)
FileName = "c:\" & FileName & "_Query.txt"
Open FileName For Output Access Write As #FNum

'クエリ分ループ
For Each Qdf In Dbs.QueryDefs

    'クエリ名＆SQLステートメント取得
    stSQL = "QueryName:" & Qdf.Name & vbCrLf & _
            "SQL:" & Qdf.Sql & vbCrLf & vbCrLf

    'ファイルに出力
    Print #FNum, stSQL

Next

Set Dbs = Nothing

Close #FNum

'ファイルを開く(notepad.exe)
ret = Shell("notepad.exe " & FileName, vbNormalFocus)

End Sub

‘エクスポートSQL
Sub exportQueryAsSqlFile()

Dim db, query, nFP As Integer

MkDir (CurrentProject.Path & "\sql")

Set db = Application.CurrentDb
For Each query In db.QueryDefs

    Debug.Print query.Name


    nFP = FreeFile
    Open CurrentProject.Path & "\sql\" & query.Name & ".sql" For Output As nFP
    Print #nFP, query.Sql
    Close nFP

Next query

End Sub

Sub フォルダ内のファイル名一覧を取得Dir() Dim buf As String, cnt As Long Const Path As String = “C:\Sample\” buf = Dir(Path & “*.xlsx”) Do While buf <> “” cnt = cnt + 1 Cells(cnt, 1) = buf buf = Dir() Loop End Sub Sub フォルダ内のファイル名一覧を取得_FileSystemObjectオブジェクト変数()
Dim FSO As Object
Set FSO = CreateObject(“Scripting.FileSystemObject”)
With FSO.GetFolder(“C:\”)
MsgBox .Files.Count & “個のファイルがあります”, vbInformation
End With
Set FSO = Nothing
End Sub

Sub フォルダ内のファイル名一覧を取得_FileSystemObject_with()
With CreateObject(“Scripting.FileSystemObject”)
If .DriveExists(“E”) Then
MsgBox “Eドライブが存在します”, vbInformation
Else
MsgBox “Eドライブは存在しません”, vbExclamation
End If
End With
End Sub

Sub シート名一覧取得()

Dim objSheetName As Worksheet
Dim objSheetNameMT As Worksheet
Dim i As Integer

'シート一覧を出力するシートを指定します。
Set objSheetNameMT = Sheets("一覧")
'一覧シートの内容を削除します。
objSheetNameMT.Columns("A:B").Clear
i = 1

'Sheetsから1シートづつ取得します。
For Each objSheetName In Sheets
    '一覧シートはスキップします。
    If objSheetName.Name <> "一覧" Then
        'シート名を取得します。そして一覧シートへ出力します。
        objSheetNameMT.Cells(i, 1).Value = objSheetName.Name
        'A1セルの値を取得します。そして一覧シートへ出力します。
        objSheetNameMT.Cells(i, 2).Value = objSheetName.Range("A1")

        'シートへのハイパーリンクを設定します。
        ActiveSheet.Hyperlinks.Add Anchor:=objSheetNameMT.Cells(i, 1), Address:="", SubAddress:="'" & objSheetName.Name & "'!A1", TextToDisplay:=objSheetName.Name

        i = i + 1
    End If
Next

End Sub

Sub ブック内の名前の定義一覧を取得()

Dim i As Integer
Dim a As Variant

‘先頭にシート「名前の定義」を追加
Worksheets.Add(Before:=Worksheets(1)).Name = “名前の定義”

‘ヘッダー行を入力
ActiveSheet.Cells(1, 1).Value = “名前の定義”
ActiveSheet.Cells(1, 2).Value = “参照先セル範囲”
ActiveSheet.Cells(1, 3).Value = “親要素（ブック名、シート名）”
ActiveSheet.Cells(1, 4).Value = “設定シート名”

‘ブック内の名前の定義を取得して書き出し
i = 1
‘ブック内の名前の定義で、ループ
For Each a In ActiveWorkbook.Names
i = i + 1
ActiveSheet.Cells(i, 1) = a.Name ‘名前を取得
ActiveSheet.Cells(i, 2) = “‘” & a.RefersTo ‘参照先を取得
ActiveSheet.Cells(i, 3) = a.Parent.Name ‘親要素を取得
ActiveSheet.Cells(i, 4) = Range(a).Parent.Name ‘シート名
Next

End Sub

Sub ◆最下行を取得()

End Sub

Sub ◆値化()

End Sub

Sub ブック内の条件付き書式一覧を取得()

‘先頭にシート「条件付き書式」を追加
Worksheets.Add(Before:=Worksheets(1)).Name = “条件付き書式”

Dim fc As FormatCondition
For Each fc In Cells.FormatConditions
If fc.Type = xlExpression Then
Debug.Print _
fc.AppliesTo.Address(False, False) & vbTab & _
fc.Formula1
End If
Next fc
End Sub

Sub アクティブシートの条件付き書式一覧を取得()

Dim xRg As Range, xCell As Range
Dim xFormat As Object
Dim xFmStr, xFmAddress As String
Dim xDic As New Dictionary
Dim xSpArr, xOperatorArr

On Error Resume Next

Set xRg = ActiveSheet.Cells.SpecialCells(xlCellTypeAllFormatConditions)

If xRg Is Nothing Then Exit Sub

xDic.Item(“Title”) = “Type|Typename|Range|StopIfTrue|Operator|Formula1|Formula2|Formula3”

If xSpArr.Count = 0 Then
xSpArr = Split(“Cell Value|Expression|Color Scale|DataBar|Top 10|Icon Sets||Unique Values|Text|Blanks|Time Period|Above Average||No Blanks||Errors|No Errors|||||”, “|”)
xOperatorArr = Split(“xlBetween|xlNotBetween|xlEqual|xlNotEqual|xlGreater|xlLess|xlGreaterEqual|xlLessEqual”, “|”)
End If

For Each xCell In xRg
Set xFormat = xCell.FormatConditions(1)
xFmAddress = xFormat.AppliesTo.Address
If Not xDic.Exists(xFmAddress) Then
xDic.Item(xFmAddress) = xFormat.Type & “|” & xSpArr(xFormat.Type – 1) & “|” & xFmAddress & “|” & xFormat.StopIfTrue
If Not IsEmpty(xFormat.Operator) Then
xDic.Item(xFmAddress) = xDic.Item(xFmAddress) & “|” & xOperatorArr(xFormat.Operator – 1)
End If

    If Not IsEmpty(xFormat.Formula1) Then
        xDic.Item(xFmAddress) = xDic.Item(xFmAddress) & "|'" & xFormat.Formula1
    End If
End If

Next

If ActiveWorkbook.Worksheets(“FmCondictionList”) Is Nothing Then
Sheets.Add.Name = “FmCondictionList”
End If

Sheets(“FmCondictionList”).Cells(1).Resize(xDic.Count) = Application.Transpose(xDic.items)
Sheets(“FmCondictionList”).Columns(1).TextToColumns , , , , 0, 0, 0, 0, -1, “|”

End Sub

Sub ブック内のリンク一覧を取得()

Dim sht             As Worksheet    '// ワークシート
Dim ar()            As String       '// ハイパーリンク配列
Dim hLink           As Hyperlink    '// ハイパーリンク
Dim sCellAddress    As String       '// セル座標
Dim sLinkAddress    As String       '// リンク先
Dim sType           As String       '// 種類
Dim s               As Variant      '// 配列の要素文字列
Dim v               As Variant      '// 分割

ReDim ar(0)

'// アクティブブックの全シートをループ
For Each sht In Worksheets
    '// シート内のハイパーリンクをループ
    For Each hLink In sht.Hyperlinks
        '// Range（セル）の場合
        If hLink.Type = msoHyperlinkRange Then
            sCellAddress = hLink.Range.Address(False, False)
            sType = "セル"
        '// Shape（画像）の場合
        ElseIf hLink.Type = msoHyperlinkShape Then
            sCellAddress = hLink.Shape.TopLeftCell.Address(False, False)
            sType = "画像"
        End If

        '// 外部リンクが設定されている場合
        If hLink.Address <> "" Then
            '// 外部へのハイパーリンクを取得
            sLinkAddress = hLink.Address
        '// 内部リンクが設定されている場合
        Else
            '// 内部へのハイパーリンクを取得
            sLinkAddress = hLink.SubAddress
        End If

        '// シート名＋セル座標＋種類＋アドレス
        ar(UBound(ar)) = sht.Name & vbTab & sCellAddress & vbTab & sType & vbTab & sLinkAddress
        ReDim Preserve ar(UBound(ar) + 1)
    Next
Next

'// 配列に格納済みの場合
If IsEmpty(ar(0)) = False Then
    '// 余分な領域を削除
    ReDim Preserve ar(UBound(ar) - 1)
End If

‘先頭にシート「条件付き書式」を追加
Worksheets.Add(Before:=Worksheets(1)).Name = “リンク”

'ヘッダー行を入力

‘ ActiveSheet.Cells(1, 1).Value = “シート名”
‘ ActiveSheet.Cells(1, 2).Value = “座標”
‘ ActiveSheet.Cells(1, 3).Value = “種類”
‘ ActiveSheet.Cells(1, 4).Value = “アドレス”

'// ハイパーリンクの数ループ
For Each s In ar
    '// TAB文字で分割
    v = Split(s, vbTab)
    '// A列にシート名を出力
    ActiveCell.Value = v(0)
    '// B列に座標を出力
    ActiveCell.Offset(0, 1).Value = v(1)
    '// C列に種類を出力
    ActiveCell.Offset(0, 2).Value = v(2)
    '// D列にアドレスを出力
    ActiveCell.Offset(0, 3).Value = v(3)

    '// 下のセルを選択
    ActiveCell.Offset(1, 0).Select
Next

End Sub
Sub アクティブなブックの全コメントを一覧にする()
Const ROW_HEAD As Long = 1 ‘ コメント一覧の見出し行とする行番号

Dim cmnt As Comment
Dim cnt_sh As Long ‘ ワークシートの枚数
Dim num_row As Long ‘ コメントを一覧にして出力する行番号
Dim msg As String

‘ コメント一覧を作成するシートの挿入と見出しの作成
‘ Worksheets.Add(Before:=Worksheets(Worksheets.Count)).Name = “名前の定義”
Worksheets.Add(Before:=Worksheets(1)).Name = “コメント”

Cells(ROW_HEAD, 1).Value = “ワークシート名”
Cells(ROW_HEAD, 2).Value = “セル番地”
Cells(ROW_HEAD, 3).Value = “コメント”
‘ コメント一覧の作成
num_row = ROW_HEAD
For cnt_sh = 2 To Worksheets.Count
For Each cmnt In Worksheets(cnt_sh).Comments
num_row = num_row + 1
Cells(num_row, 1).Value = Worksheets(cnt_sh).Name
Cells(num_row, 2).Value = cmnt.Parent.Address(False, False)
Cells(num_row, 3).Value = cmnt.Text
Next cmnt
Next cnt_sh

msg = “”
If num_row = ROW_HEAD Then
‘ コメントが存在しないときに挿入したコメント一覧用シートを削除
Application.DisplayAlerts = False
Worksheets(1).Delete
Application.DisplayAlerts = True
msg = “アクティブなブックにコメントは存在しません。”
Else
msg = “『” & Worksheets(1).Name & “』にコメント一覧を作成しました。”
End If
MsgBox msg
End Sub

Sub シェイプ数をカウント()
MsgBox ActiveSheet.Shapes.Count
End Sub

Sub Sample1()

‘図形を指定
Dim Shp As Shape

For Each Shp In ActiveSheet.Shapes

With Shp

'名前を取得する
Debug.Print "Name: " & .Name & ", type: " & .Type & " , Top: " & .Top & ", AlternativeText: " & .AlternativeText

‘ Debug.Print Top

‘ MsgBox “Name” & .Name & “type” & .Type & .MsoShapeType & .ShapeRange.Type

End With

Next Shp

End Sub

Sub 入力規則のTypeを調べるFor_Each() Dim rng As Range On Error GoTo ERR_HNDL For Each rng In Cells.SpecialCells(xlCellTypeAllValidation) Debug.Print
rng.Address(False, False) & vbTab & _
rng.Validation.Type
Next rng
Exit Sub
ERR_HNDL:
Err.Clear
MsgBox “入力規則が設定されていません。”
End Sub

Sub ◆ブック内のシートの保護一覧を取得()

End Sub

Sub ◆ブック内のmodue()

End Sub

Sub csv読込1()

Application.ScreenUpdating = False

Dim OpenFileName As Variant
OpenFileName = Application.GetOpenFilename _
        ("CSVファイル,*.csv*", MultiSelect:=True)

If Not IsArray(OpenFileName) Then
    MsgBox "キャンセルしました。": Exit Sub
End If

Dim FSO As FileSystemObject
Set FSO = New FileSystemObject

Dim n As Long '選択したファイル数、処理を繰り返す
For n = LBound(OpenFileName) To UBound(OpenFileName)

    Dim WB As Workbook
    Set WB = Workbooks.Open(OpenFileName(n))

    Dim strBaseName As String
    strBaseName = FSO.GetBaseName(WB.Name) '拡張子を除くファイル名を取得

    '同じファイル名で同じ階層にExcel形式で保存する
    WB.SaveAs _
    FileName:=WB.Path & "\" & strBaseName, FileFormat:=xlWorkbookDefault

    WB.Close SaveChanges:=False

    Set WB = Nothing 'いったん解放

Next n

Application.ScreenUpdating = True

MsgBox "終了しました。"

End Sub
Sub CSV読込2()

Dim myFileName As Variant
Dim Fcn As Long
Dim i As Long
Dim buf As String
Dim tmp As Variant

myFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
                                                                      Title:="CSVファイルの選択")
If myFileName = False Then
      Exit Sub
End If

With Worksheets("Sheet1")

    Open myFileName For Input As #1

    Do Until EOF(1)
        Line Input #1, buf
        Fcn = Fcn + 1
        tmp = Split(buf, ",")

    '書き出し
        .Cells(Fcn + 1, 1).NumberFormatLocal = "@"
        .Cells(Fcn + 1, 1).Value = CStr(tmp(0))
        .Cells(Fcn + 1, 2).NumberFormatLocal = "yyyy年m月d日"
        .Cells(Fcn + 1, 2).Value = DateValue(tmp(1))

        For i = 2 To UBound(tmp)
            .Cells(Fcn + 1, i + 1).Value = tmp(i)
        Next i

    Loop
    Close #1

End With

End Sub

Sub CSV読込3()

Dim myFileName As Variant
Dim Fcn As Long
Dim i As Long, j As Long
Dim buf As String
Dim tmp As Variant
Dim tmp2() As Variant
Dim cnt As Integer
Dim myflag As Boolean

    myFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
                                                                  Title:="CSVファイルの選択")
    If myFileName = False Then
        Exit Sub
    End If

With Worksheets("Sheet1")

    Open myFileName For Input As #1

    Do Until EOF(1)
        Line Input #1, buf
        Fcn = Fcn + 1
        tmp = Split(buf, ",")
        myflag = False
        cnt = 0

        For i = LBound(tmp) To UBound(tmp)

            If myflag = False And Left(tmp(i), 1) = """" And Right(tmp(i), 1) = """" Then
                cnt = cnt + 1
                ReDim Preserve tmp2(cnt)
                tmp2(cnt) = Mid(tmp(i), 2, Len(tmp(i)) - 2)

            ElseIf myflag = False And Left(tmp(i), 1) <> """" And Right(tmp(i), 1) <> """" Then
                cnt = cnt + 1
                ReDim Preserve tmp2(cnt)
                tmp2(cnt) = tmp(i)

            ElseIf Left(tmp(i), 1) = """" And Right(tmp(i), 1) <> """" Then
                cnt = cnt + 1
                ReDim Preserve tmp2(cnt)
                tmp2(cnt) = Mid(tmp(i), 2, Len(tmp(i)))
                myflag = True

          ElseIf myflag = True And Left(tmp(i), 1) <> """" And Right(tmp(i), 1) <> """" Then
              tmp2(cnt) = tmp2(cnt) & tmp(i)

          ElseIf myflag = True And Left(tmp(i), 1) <> """" And Right(tmp(i), 1) = """" Then
              tmp2(cnt) = tmp2(cnt) & Left(tmp(i), Len(tmp(i)) - 1)
              myflag = False
          End If

        Next i

        '書き出し
            For i = 1 To UBound(tmp2)
                .Cells(Fcn + 1, i).Value = tmp2(i)
            Next i

    Loop
    Close #1

End With

End Sub

Sub 複数ブック1ブック化()
Application.ScreenUpdating = False ‘画面更新を一時停止

Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索

Do Until fname = Empty '全て検索
    If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ
        Set WB = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
        WB.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く
        WB.Close (False) '保存の有無を聞かずに保存しないで閉じる
        n = n + 1 'ブック数をカウント
    End If

    fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す

Application.ScreenUpdating = True '画面更新一時停止を解除

MsgBox n & "件のブックをコピーしましました。"

End Sub

Sub 複数シート1シート化()
Dim sWS As Worksheet ‘データシート（コピー元）
Dim dWS As Worksheet ‘集約用シート（コピー先）

Set dWS = Worksheets("AllData")

'集約用シートの2行目以降を削除
dWS.UsedRange.Offset(1, 0).Clear

'各シートの2行目以降のデータを、集約用シートの末尾にコピー
For Each sWS In Worksheets
    If sWS.Name <> dWS.Name Then
        With sWS.UsedRange

            'コピー元シートにデータが1件以上ある場合
            If .Rows.Count > 1 Then
                .Offset(1, 0).Resize(.Rows.Count - 1).Copy _
                    Destination:=dWS.Cells(Rows.Count, 1). _
                                    End(xlUp).Offset(1, 0)
            End If

        End With
    End If
Next sWS

'集計用シートをA列で並べ替え
dWS.UsedRange.Sort Key1:=Range("A1"), Header:=xlYes

End Sub

Sub SearchFomula()
‘アクティブシートの数式が入力されたセルをイミディエイトウィンドウへ出力する
Dim r As Range ‘// 1セル
Dim f ‘// Formulaプロパティ値
Dim v ‘// Valueプロパティ値
Dim adrs ‘// セル位置
Dim msg ‘// 出力メッセージ

'// 入力セル範囲をループ
For Each r In ActiveSheet.UsedRange
    '// FormulaプロパティとValueプロパティを取得
    f = r.Formula
    v = r.Value

    '// 一番左が「=」で、かつ、FormulaプロパティとValueプロパティが異なる場合
    If Left(f, 1) = "=" And f <> v Then
        adrs = r.Address(False, False)
        msg = msg & adrs & vbCr
    End If
Next

Debug.Print msg

‘ ‘// メッセージボックスに出力
‘ Call MsgBox(msg)
End Sub

Sub ListLinks()
‘外部参照を一覧表示する

Dim xSheet As Worksheet
Dim xRg As Range
Dim xCell As Range
Dim xCount As Long
Dim xLinkArr() As String
On Error Resume Next
For Each xSheet In Worksheets
    Set xRg = xSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
    If xRg Is Nothing Then GoTo LblNext
    For Each xCell In xRg
        If InStr(1, xCell.Formula, "[") > 0 Then
            xCount = xCount + 1
            ReDim Preserve xLinkArr(1 To 2, 1 To xCount)
            xLinkArr(1, xCount) = xCell.Address(, , , True)
            xLinkArr(2, xCount) = "'" & xCell.Formula
       End If
    Next

LblNext:
Next
If xCount > 0 Then
Sheets.Add(Sheets(1)).Name = “Link Sheet”
Range(“A1”).Resize(, 2).Value = Array(“Location”, “Reference”)
Range(“A2”).Resize(UBound(xLinkArr, 2), UBound(xLinkArr, 1)).Value = Application.Transpose(xLinkArr)
Columns(“A:B”).AutoFit
Else
MsgBox “No links were found within the active workbook.”, vbInformation, “KuTools for Excel”
End If
End Sub

コメント

タイトルとURLをコピーしました