Sub ボタン1_Click()
Dim A As String
Dim cnt As Long
On Error Resume Next
A = Dir("c:\Work\*.xlsx")
Application.DisplayAlerts = False
Do While A <> ""
cnt = cnt + 1
Cells(cnt, 1) = A
SendKeys "{ESC}"
Cells(cnt, 2) = "='c:\Work\[" & A & "]Sheet1'!A1"
A = Dir()
Loop
Application.DisplayAlerts = True
With Range(Range("B1"), Range("B1").End(xlDown))
.Value = .Value
End With
End Sub
Option Compare Database
Option Explicit
Private Sub cmdCreateExcelFiles_Click()
Dim DesktopPath As String, FilePath As String, WSH As Variant
Set WSH = CreateObject("Wscript.Shell")
DesktopPath = WSH.SpecialFolders("Desktop")
'FilePath = DesktopPath & "\work" & "\CreatedByVBAFile.xlsx"
Dim i As Long
For i = 1 To 100
FilePath = DesktopPath & "\work" & "\CreatedByVBAFile" & i & ".xlsx"
Call CreateExcelFiles(FilePath)
Next i
Set WSH = Nothing
End Sub
Private Sub cmdCheckPass_Click()
Dim ExApp As Object
Set ExApp = CreateObject("Excel.Application")
ExApp.Visible = True
Dim DesktopPath As String, FilePath As String, WSH As Variant
Set WSH = CreateObject("Wscript.Shell")
DesktopPath = WSH.SpecialFolders("Desktop")
FilePath = DesktopPath & "\createdExcel.xlsx"
ExApp.Workbooks.Add
Dim A As String
Dim cnt As Long
On Error Resume Next
A = Dir("C:\Users\ユーザー名\Desktop\work\*.xlsx")
ExApp.DisplayAlerts = False
Do While A <> ""
cnt = cnt + 1
ExApp.Workbooks(ExApp.Workbooks.Count).Sheets(1).Cells(cnt, 1) = A
ExApp.SendKeys "{ESC 3}"
ExApp.Workbooks(ExApp.Workbooks.Count).Sheets(1).Cells(cnt, 2) = "='C:\Users\ユーザー名\Desktop\work\[" & A & "]Sheet1'!A1"
If (IsError(ExApp.Workbooks(ExApp.Workbooks.Count).Sheets(1).Cells(cnt, 2))) Then
ExApp.Workbooks(ExApp.Workbooks.Count).Sheets(1).Cells(cnt, 3) = "Locked"
Else
ExApp.Workbooks(ExApp.Workbooks.Count).Sheets(1).Cells(cnt, 3) = "---"
End If
A = Dir()
Loop
' With Range(Range("B1"), Range("B1").End(xlDown))
' .Value = .Value
' End With
With ExApp.Workbooks(ExApp.Workbooks.Count)
.SaveAs FileName:=FilePath
.Close
End With
ExApp.Quit
Set ExApp = Nothing
Set WSH = Nothing
End Sub
Private Sub CreateExcelFiles(getFileName As String)
Dim ExApp As Object
Set ExApp = CreateObject("Excel.Application")
ExApp.Visible = False
Dim DesktopPath As String, FilePath As String, WSH As Variant
Set WSH = CreateObject("Wscript.Shell")
DesktopPath = WSH.SpecialFolders("Desktop")
FilePath = getFileName
ExApp.Workbooks.Add
With ExApp.Workbooks(ExApp.Workbooks.Count)
.Sheets(1).Cells(1, 1) = Now()
.SaveAs FileName:=FilePath
.Close
End With
ExApp.Quit
Set ExApp = Nothing
Set WSH = Nothing
End Sub
コメント