我有主文件夹，它有子文件夹。每个子文件夹都有四个文件，名为bcst-subfoldername，pcpt-subfoldername，corsi-subfoldername，SCL-subfolder name。我想从准备好的excel书中获取这些文件的信息。我把下标超出范围错误＆＃34;运行时错误9＆＃34;其中粗体输入代码。我怎样才能使它工作或我的逻辑是真的？
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Bİr dosya seçiniz"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Function Recurse(sPath As String) As String
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Set myFolder = FSO.GetFolder(sPath)
Dim Str As String
Dim sItem2 As String
Dim sItem3 As String
Dim sItem4 As String
Dim sItem5 As String
Dim sItem6 As String
Dim sItem7 As String
Dim sItem8 As String
Dim sItem9 As String
Dim sItem10 As String
Dim sItem11 As String
Dim sItem12 As String
Dim finalString As String
Dim finalString2 As String
Dim finalString3 As String
Dim finalString4 As String
Dim finalString5 As String
Dim finalString6 As String
Dim finalString7 As String
Dim finalString8 As String
Dim finalString9 As String
Dim finalString10 As String
Dim finalString11 As String
Dim indexOfChar As Integer
Dim indexOfChar2 As Integer
Dim indexOfChar3 As Integer
Dim indexOfChar4 As Integer
Dim indexOfChar5 As Integer
Dim indexOfChar6 As Integer
Dim indexOfChar7 As Integer
Dim indexOfChar8 As Integer
Dim indexOfChar9 As Integer
Dim indexOfChar10 As Integer
Dim indexOfChar11 As Integer
For Each mySubFolder In myFolder.SubFolders
Application.ScreenUpdating = False
Set ana = Workbooks.Open("C:\Users\Burak\Desktop\2MacroDegerlendirme.xlsm").Sheets("Sayfa1") 'Hangi sayfaya alınacak?
For Each myFile In mySubFolder.Files
Str = myFile.Name
If InStr(Str, "bcst") >= 0 Then
Set dosya = Workbooks.Open(mySubFolder & "\" & Str) 'Alınacak dosyanın uzantısı ne?
sItem2 = dosya.Sheets(ActiveSheet.Name).Range("A4")
indexOfChar = InStr(1, sItem2, ":")
finalString = Right(sItem2, Len(sItem2) - indexOfChar)
ana.Range("F7") = finalString & "." 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem3 = dosya.Sheets(ActiveSheet.Name).Range("A5")
indexOfChar2 = InStr(1, sItem3, ":")
finalString2 = Right(sItem3, Len(sItem3) - indexOfChar2)
ana.Range("F8") = finalString2 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem4 = dosya.Sheets(ActiveSheet.Name).Range("A7")
indexOfChar3 = InStr(1, sItem4, ":")
finalString3 = Right(sItem4, Len(sItem4) - indexOfChar3)
ana.Range("F9") = finalString3 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem5 = dosya.Sheets(ActiveSheet.Name).Range("A6")
indexOfChar4 = InStr(1, sItem5, ":")
finalString4 = Right(sItem5, Len(sItem5) - indexOfChar4)
ana.Range("F10") = finalString4 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem6 = dosya.Sheets(ActiveSheet.Name).Range("A8")
indexOfChar5 = InStr(1, sItem6, ":")
finalString5 = Right(sItem6, Len(sItem6) - indexOfChar5)
ana.Range("F11") = finalString5 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem7 = dosya.Sheets(ActiveSheet.Name).Range("A11")
indexOfChar6 = InStr(1, sItem7, ":")
finalString6 = Right(sItem7, Len(sItem7) - indexOfChar6)
ana.Range("F12") = finalString6 'Hangi sayfanın hangi hücresi nereye alınacak?
dosya.Close
Application.ScreenUpdating = True
ThisWorkbook.Save
End If
If InStr(Str, "ptrails") >= 0 Then
Set dosya = Workbooks.Open(mySubFolder & "\" & Str)
sItem2 = dosya.Sheets(ActiveSheet.Name).Range("A18")
indexOfChar = InStr(1, sItem2, ":")
finalString = Right(sItem2, Len(sItem2) - indexOfChar)
ana.Range("B7") = finalString & "." 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem3 = dosya.Sheets(ActiveSheet.Name).Range("A19")
indexOfChar2 = InStr(1, sItem3, ":")
finalString2 = Right(sItem3, Len(sItem3) - indexOfChar2)
MsgBox finalString
ana.Range("B8") = finalString2 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem4 = dosya.Sheets(ActiveSheet.Name).Range("A16")
indexOfChar3 = InStr(1, sItem4, ":")
finalString3 = Right(sItem4, Len(sItem4) - indexOfChar3)
ana.Range("B9") = finalString3 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem5 = dosya.Sheets(ActiveSheet.Name).Range("A34")
indexOfChar4 = InStr(1, sItem5, ":")
finalString4 = Right(sItem5, Len(sItem5) - indexOfChar4)
ana.Range("B10") = finalString4 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem6 = dosya.Sheets(ActiveSheet.Name).Range("A35")
indexOfChar5 = InStr(1, sItem6, ":")
finalString5 = Right(sItem6, Len(sItem6) - indexOfChar5)
ana.Range("B11") = finalString5 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem7 = dosya.Sheets(ActiveSheet.Name).Range("A32")
indexOfChar6 = InStr(1, sItem7, ":")
finalString6 = Right(sItem7, Len(sItem7) - indexOfChar6)
ana.Range("B12") = finalString6 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem8 = dosya.Sheets(ActiveSheet.Name).Range("A50")
indexOfChar7 = InStr(1, sItem8, ":")
finalString7 = Right(sItem8, Len(sItem8) - indexOfChar7)
ana.Range("B13") = finalString7 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem9 = dosya.Sheets(ActiveSheet.Name).Range("A51")
indexOfChar8 = InStr(1, sItem9, ":")
finalString8 = Right(sItem9, Len(sItem9) - indexOfChar8)
ana.Range("B14") = finalString8 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem10 = dosya.Sheets(ActiveSheet.Name).Range("A48")
indexOfChar9 = InStr(1, sItem10, ":")
finalString9 = Right(sItem10, Len(sItem10) - indexOfChar9)
ana.Range("B15") = finalString9 'Hangi sayfanın hangi hücresi nereye alınacak?
dosya.Close
Application.ScreenUpdating = True
ThisWorkbook.Save
End If
If InStr(Str, "SCL") >= 0 Then
Set dosya = Workbooks.Open(mySubFolder & "\" & Str)
**sItem2 = dosya.Sheets("dd").Range("C3")**
indexOfChar = InStr(1, sItem2, ":")
finalString = Right(sItem2, Len(sItem2) - indexOfChar)
ana.Range("E16") = finalString & "." 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem3 = dosya.Sheets("Değerlendirme").Range("C4")
indexOfChar2 = InStr(1, sItem3, ":")
finalString2 = Right(sItem3, Len(sItem3) - indexOfChar2)
ana.Range("E17") = finalString2 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem4 = dosya.Sheets("Değerlendirme").Range("C5")
indexOfChar3 = InStr(1, sItem4, ":")
finalString3 = Right(sItem4, Len(sItem4) - indexOfChar3)
ana.Range("E18") = finalString3 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem5 = dosya.Sheets("Değerlendirme").Range("C6")
indexOfChar4 = InStr(1, sItem5, ":")
finalString4 = Right(sItem5, Len(sItem5) - indexOfChar4)
ana.Range("E19") = finalString4 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem6 = dosya.Sheets("Değerlendirme").Range("C7")
indexOfChar5 = InStr(1, sItem6, ":")
finalString5 = Right(sItem6, Len(sItem6) - indexOfChar5)
ana.Range("E20") = finalString5 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem7 = dosya.Sheets("Değerlendirme").Range("C8")
indexOfChar6 = InStr(1, sItem7, ":")
finalString6 = Right(sItem7, Len(sItem7) - indexOfChar6)
ana.Range("E21") = finalString6 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem8 = dosya.Sheets("Değerlendirme").Range("C9")
indexOfChar7 = InStr(1, sItem8, ":")
finalString7 = Right(sItem8, Len(sItem8) - indexOfChar7)
ana.Range("E22") = finalString7 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem9 = dosya.Sheets("Değerlendirme").Range("C10")
indexOfChar8 = InStr(1, sItem9, ":")
finalString8 = Right(sItem9, Len(sItem9) - indexOfChar8)
ana.Range("E23") = finalString8 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem10 = dosya.Sheets("Değerlendirme").Range("C11")
indexOfChar9 = InStr(1, sItem10, ":")
finalString9 = Right(sItem10, Len(sItem10) - indexOfChar9)
ana.Range("E24") = finalString9 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem11 = dosya.Sheets("Değerlendirme").Range("C12")
indexOfChar10 = InStr(1, sItem11, ":")
finalString10 = Right(sItem11, Len(sItem11) - indexOfChar10)
ana.Range("E25") = finalString10 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem12 = dosya.Sheets("Değerlendirme").Range("C13")
indexOfChar11 = InStr(1, sItem12, ":")
finalString11 = Right(sItem12, Len(sItem12) - indexOfChar11)
ana.Range("E26") = finalString11 'Hangi sayfanın hangi hücresi nereye alınacak?
dosya.Close
Application.ScreenUpdating = True
ThisWorkbook.Save
End If
If InStr(Str, "corsi") >= 0 Then
Set dosya = Workbooks.Open(mySubFolder & "\" & Str)
sItem2 = dosya.Sheets(ActiveSheet.Name).Range("A7")
indexOfChar = InStr(1, sItem2, ":")
finalString = Right(sItem2, Len(sItem2) - indexOfChar)
ana.Range("B19") = finalString & "." 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem3 = dosya.Sheets(ActiveSheet.Name).Range("A6")
indexOfChar2 = InStr(1, sItem3, ":")
finalString2 = Right(sItem3, Len(sItem3) - indexOfChar2)
ana.Range("B20") = finalString2 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem4 = dosya.Sheets(ActiveSheet.Name).Range("A17")
indexOfChar3 = InStr(1, sItem4, ":")
finalString3 = Right(sItem4, Len(sItem4) - indexOfChar3)
ana.Range("B21") = finalString3 'Hangi sayfanın hangi hücresi nereye alınacak?
sItem5 = dosya.Sheets(ActiveSheet.Name).Range("A16")
indexOfChar4 = InStr(1, sItem5, ":")
finalString4 = Right(sItem5, Len(sItem5) - indexOfChar4)
ana.Range("B22") = finalString4 'Hangi sayfanın hangi hücresi nereye alınacak?
ThisWorkbook.Save
End If
If InStr(Str, "pcpt") >= 0 Then
Set dosya = Workbooks.Open(mySubFolder & "\" & Str)
Dim i As Integer
Dim correct As Integer
Dim miss As Integer
miss = 0
incorrect = 0
For i = 2 To 243
If Cells(i, 6).Value = 0 And Cells(i, 7).Value = 0 Then
miss = miss + 1
ElseIf Cells(i, 6).Value = 1 And Cells(i, 7).Value = 0 Then
incorrect = incorrect + 1
End If
Next i
ana.Range("B24") = incorrect
ana.Range("B25") = miss
dosya.Close
Application.ScreenUpdating = True
ThisWorkbook.Save
End If
Exit For
Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function
Sub TestR()
Call Recurse(GetFolder)
End Sub