//十分なエラーテストは実施していません ご参考程度に
Sub makeP_Worksheet()
Dim targetFileName, targetFileName2, myPath, mePath As String
Dim flag As Boolean
Dim mySheetName(), LastRow As Variant
Dim cnt, i, FirstRow, myCnt As Long
Dim myRange, myObj, myFind As Range
Dim wb, wb2, myPeople As String
Dim myWb As Workbook
Dim myWbCnt As Long
On Error Resume Next
Dim bk As Workbook
For Each bk In Workbooks
If Not (bk Is ThisWorkbook) Then
bk.Close SaveChanges:=False
End If
Next
myPath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1)
mePath = ThisWorkbook.Path
targetFileName = mePath & "\" & "集計.xlsx"
targetFileName2 = myPath & "\" & "名簿.csv"
Set wb = Workbooks.Open(targetFileName)
myWbCnt = wb.Worksheets.Count
Set wb2 = Workbooks.Open(targetFileName2)
LastRow = wb2.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
If myWbCnt < LastRow Then
wb.Worksheets.Add After:=Worksheets(1), Count:=LastRow
End If
Set myRange = Range(Cells(1, 1), Cells(LastRow, 1))
Set myObj = myRange.Find(What:="*", SearchOrder:=xlByRows)
If myObj Is Nothing Then
Exit Sub
End If
wb.Worksheet(2).Name = myObj
' Debug.Print myObj & wb.Name
' Debug.Print myObj
FirstRow = myObj
' Debug.Print FirstRow
Set myFind = myObj
ReDim mySheetName(LastRow)
mySheetName(0) = myObj
wb.Worksheets(2).Name = mySheetName(0)
i = 1
Do
'// 次を検索
Set myFind = myRange.FindNext(After:=myFind)
mySheetName(i) = myFind
' Debug.Print myFind(i)
wb.Worksheets(2 + i).Name = mySheetName(i)
'// 検索不一致時はループを抜ける
If myFind Is Nothing Then
Exit Do
End If
'// 最初に検索されたセルが再検索された場合
If myFind.Address = myObj.Address Then
Exit Do
End If
' Debug.Print myFind
' mySheetName(i) = myFind
Debug.Print mySheetName(i)
i = i + 1
Loop
End Sub
