Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
stuck in loop
Hi all,
I've altered the code for browse and protect that Dave Peterson helped me with and now it gets stuck in a loop. The original code looped though all workbooks in browsed for folder and then looped through all worksheets with a for each loop. I altered the code to do a different job. What I wanted to do was copy an array of sheets from the workbook with the code to all the workbooks in the folder. Here's the bits of code This is the end of the browse for filename code Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If Next End Sub This is the bit that replaced the for each unprotect Sub CopyTemplates (myWB As Workbook) Set myWB = ActiveWorkbook ThisWorkbook.Worksheets(Array("Datasheet1", "Datasheet2", "Datasheet3", _ "Charts1", "Charts2", "Charts3", "Summary")).Copy _ Befo=myWB.Worksheets(1) myWB.Close savechanges:=True End Sub If anyone could tell me what's missing please, I'd be more than grateful. Thank you -- Trish |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
stuck in loop
Since you're passing myWB to that subroutine, you don't need to rely on the
activeworkbook. But I don't see anything in the snippet of code that would cause a loop. This worked fine for me: Option Compare Text Option Explicit Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 Private Const BIF_RETURNFSANCESTORS As Long = &H8 Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 Private Const BIF_BROWSEFORPRINTER As Long = &H2000 Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 Private Const MAX_PATH As Long = 260 Type BrowseInfo hOwner As Long pidlRoot As Long pszDisplayName As String lpszINSTRUCTIONS As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Boolean hNameMappings As Long lpszProgressTitle As String End Type Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _ ByVal pidl As Long, _ ByVal pszBuffer As String) As Long Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _ lpBrowseInfo As BrowseInfo) As Long Function BrowseFolder(Optional Caption As String = "") As String Dim BrowseInfo As BrowseInfo Dim FolderName As String Dim ID As Long Dim Res As Long With BrowseInfo .hOwner = 0 .pidlRoot = 0 .pszDisplayName = String$(MAX_PATH, vbNullChar) .lpszINSTRUCTIONS = Caption .ulFlags = BIF_RETURNONLYFSDIRS .lpfn = 0 End With FolderName = String$(MAX_PATH, vbNullChar) ID = SHBrowseForFolderA(BrowseInfo) If ID Then Res = SHGetPathFromIDListA(ID, FolderName) If Res Then BrowseFolder = Left$(FolderName, InStr(FolderName, _ vbNullChar) - 1) End If End If End Function Sub test() Dim myWB As Workbook Dim AutoSecurity As MsoAutomationSecurity 'Dim mymyPath As String Dim myName As String Dim myPath As String Dim Prompt As String Dim Title As String myPath = BrowseFolder("Select A Folder") If myPath = "" Then Prompt = "You didn't select a folder. The procedure has been canceled." Title = "Procedure Canceled" MsgBox Prompt, vbCritical, Title Else Prompt = "You selected the following myPath:" & vbNewLine & myPath Title = "Procedure Completed" MsgBox Prompt, vbInformation, Title If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If myName = Dir(myPath & "*.xls") If myName < "" Then Do Debug.Print myName AutoSecurity = Application.AutomationSecurity Application.AutomationSecurity = msoAutomationSecurityLow Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If End Sub Sub CopyTemplates(myWB As Workbook) 'just for testing MsgBox myWB.FullName ' ThisWorkbook.Worksheets(Array("Datasheet1", _ ' "Datasheet2", _ ' "Datasheet3", _ ' "Charts1", _ ' "Charts2", _ ' "Charts3", _ ' "Summary")).Copy _ ' Befo=myWB.Worksheets(1) ' myWB.Close savechanges:=True End Sub If you see the names correctly, then delete that line and uncomment the .copy line(s). Trish Smith wrote: Hi all, I've altered the code for browse and protect that Dave Peterson helped me with and now it gets stuck in a loop. The original code looped though all workbooks in browsed for folder and then looped through all worksheets with a for each loop. I altered the code to do a different job. What I wanted to do was copy an array of sheets from the workbook with the code to all the workbooks in the folder. Here's the bits of code This is the end of the browse for filename code Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If Next End Sub This is the bit that replaced the for each unprotect Sub CopyTemplates (myWB As Workbook) Set myWB = ActiveWorkbook ThisWorkbook.Worksheets(Array("Datasheet1", "Datasheet2", "Datasheet3", _ "Charts1", "Charts2", "Charts3", "Summary")).Copy _ Befo=myWB.Worksheets(1) myWB.Close savechanges:=True End Sub If anyone could tell me what's missing please, I'd be more than grateful. Thank you -- Trish -- Dave Peterson |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
stuck in loop
Hi Dave,
Thanks for replying. Still having problems and I know this should not be happening. When the code was commented out it behaved perfectly. It went into each workbook and showed the name in the message box and then stopped where it should. When I uncommented the code it got stuck once again. If you can help that would be more than brilliant. Thank you -- Trish "Dave Peterson" wrote: Since you're passing myWB to that subroutine, you don't need to rely on the activeworkbook. But I don't see anything in the snippet of code that would cause a loop. This worked fine for me: Option Compare Text Option Explicit Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 Private Const BIF_RETURNFSANCESTORS As Long = &H8 Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 Private Const BIF_BROWSEFORPRINTER As Long = &H2000 Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 Private Const MAX_PATH As Long = 260 Type BrowseInfo hOwner As Long pidlRoot As Long pszDisplayName As String lpszINSTRUCTIONS As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Boolean hNameMappings As Long lpszProgressTitle As String End Type Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _ ByVal pidl As Long, _ ByVal pszBuffer As String) As Long Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _ lpBrowseInfo As BrowseInfo) As Long Function BrowseFolder(Optional Caption As String = "") As String Dim BrowseInfo As BrowseInfo Dim FolderName As String Dim ID As Long Dim Res As Long With BrowseInfo .hOwner = 0 .pidlRoot = 0 .pszDisplayName = String$(MAX_PATH, vbNullChar) .lpszINSTRUCTIONS = Caption .ulFlags = BIF_RETURNONLYFSDIRS .lpfn = 0 End With FolderName = String$(MAX_PATH, vbNullChar) ID = SHBrowseForFolderA(BrowseInfo) If ID Then Res = SHGetPathFromIDListA(ID, FolderName) If Res Then BrowseFolder = Left$(FolderName, InStr(FolderName, _ vbNullChar) - 1) End If End If End Function Sub test() Dim myWB As Workbook Dim AutoSecurity As MsoAutomationSecurity 'Dim mymyPath As String Dim myName As String Dim myPath As String Dim Prompt As String Dim Title As String myPath = BrowseFolder("Select A Folder") If myPath = "" Then Prompt = "You didn't select a folder. The procedure has been canceled." Title = "Procedure Canceled" MsgBox Prompt, vbCritical, Title Else Prompt = "You selected the following myPath:" & vbNewLine & myPath Title = "Procedure Completed" MsgBox Prompt, vbInformation, Title If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If myName = Dir(myPath & "*.xls") If myName < "" Then Do Debug.Print myName AutoSecurity = Application.AutomationSecurity Application.AutomationSecurity = msoAutomationSecurityLow Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If End Sub Sub CopyTemplates(myWB As Workbook) 'just for testing MsgBox myWB.FullName ' ThisWorkbook.Worksheets(Array("Datasheet1", _ ' "Datasheet2", _ ' "Datasheet3", _ ' "Charts1", _ ' "Charts2", _ ' "Charts3", _ ' "Summary")).Copy _ ' Befo=myWB.Worksheets(1) ' myWB.Close savechanges:=True End Sub If you see the names correctly, then delete that line and uncomment the .copy line(s). Trish Smith wrote: Hi all, I've altered the code for browse and protect that Dave Peterson helped me with and now it gets stuck in a loop. The original code looped though all workbooks in browsed for folder and then looped through all worksheets with a for each loop. I altered the code to do a different job. What I wanted to do was copy an array of sheets from the workbook with the code to all the workbooks in the folder. Here's the bits of code This is the end of the browse for filename code Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If Next End Sub This is the bit that replaced the for each unprotect Sub CopyTemplates (myWB As Workbook) Set myWB = ActiveWorkbook ThisWorkbook.Worksheets(Array("Datasheet1", "Datasheet2", "Datasheet3", _ "Charts1", "Charts2", "Charts3", "Summary")).Copy _ Befo=myWB.Worksheets(1) myWB.Close savechanges:=True End Sub If anyone could tell me what's missing please, I'd be more than grateful. Thank you -- Trish -- Dave Peterson |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
stuck in loop
Maybe you could give more details on the problems you're having.
If you step through the code (hitting F8), do you see what's happening? Trish Smith wrote: Hi Dave, Thanks for replying. Still having problems and I know this should not be happening. When the code was commented out it behaved perfectly. It went into each workbook and showed the name in the message box and then stopped where it should. When I uncommented the code it got stuck once again. If you can help that would be more than brilliant. Thank you -- Trish "Dave Peterson" wrote: Since you're passing myWB to that subroutine, you don't need to rely on the activeworkbook. But I don't see anything in the snippet of code that would cause a loop. This worked fine for me: Option Compare Text Option Explicit Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 Private Const BIF_RETURNFSANCESTORS As Long = &H8 Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 Private Const BIF_BROWSEFORPRINTER As Long = &H2000 Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 Private Const MAX_PATH As Long = 260 Type BrowseInfo hOwner As Long pidlRoot As Long pszDisplayName As String lpszINSTRUCTIONS As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Boolean hNameMappings As Long lpszProgressTitle As String End Type Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _ ByVal pidl As Long, _ ByVal pszBuffer As String) As Long Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _ lpBrowseInfo As BrowseInfo) As Long Function BrowseFolder(Optional Caption As String = "") As String Dim BrowseInfo As BrowseInfo Dim FolderName As String Dim ID As Long Dim Res As Long With BrowseInfo .hOwner = 0 .pidlRoot = 0 .pszDisplayName = String$(MAX_PATH, vbNullChar) .lpszINSTRUCTIONS = Caption .ulFlags = BIF_RETURNONLYFSDIRS .lpfn = 0 End With FolderName = String$(MAX_PATH, vbNullChar) ID = SHBrowseForFolderA(BrowseInfo) If ID Then Res = SHGetPathFromIDListA(ID, FolderName) If Res Then BrowseFolder = Left$(FolderName, InStr(FolderName, _ vbNullChar) - 1) End If End If End Function Sub test() Dim myWB As Workbook Dim AutoSecurity As MsoAutomationSecurity 'Dim mymyPath As String Dim myName As String Dim myPath As String Dim Prompt As String Dim Title As String myPath = BrowseFolder("Select A Folder") If myPath = "" Then Prompt = "You didn't select a folder. The procedure has been canceled." Title = "Procedure Canceled" MsgBox Prompt, vbCritical, Title Else Prompt = "You selected the following myPath:" & vbNewLine & myPath Title = "Procedure Completed" MsgBox Prompt, vbInformation, Title If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If myName = Dir(myPath & "*.xls") If myName < "" Then Do Debug.Print myName AutoSecurity = Application.AutomationSecurity Application.AutomationSecurity = msoAutomationSecurityLow Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If End Sub Sub CopyTemplates(myWB As Workbook) 'just for testing MsgBox myWB.FullName ' ThisWorkbook.Worksheets(Array("Datasheet1", _ ' "Datasheet2", _ ' "Datasheet3", _ ' "Charts1", _ ' "Charts2", _ ' "Charts3", _ ' "Summary")).Copy _ ' Befo=myWB.Worksheets(1) ' myWB.Close savechanges:=True End Sub If you see the names correctly, then delete that line and uncomment the .copy line(s). Trish Smith wrote: Hi all, I've altered the code for browse and protect that Dave Peterson helped me with and now it gets stuck in a loop. The original code looped though all workbooks in browsed for folder and then looped through all worksheets with a for each loop. I altered the code to do a different job. What I wanted to do was copy an array of sheets from the workbook with the code to all the workbooks in the folder. Here's the bits of code This is the end of the browse for filename code Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If Next End Sub This is the bit that replaced the for each unprotect Sub CopyTemplates (myWB As Workbook) Set myWB = ActiveWorkbook ThisWorkbook.Worksheets(Array("Datasheet1", "Datasheet2", "Datasheet3", _ "Charts1", "Charts2", "Charts3", "Summary")).Copy _ Befo=myWB.Worksheets(1) myWB.Close savechanges:=True End Sub If anyone could tell me what's missing please, I'd be more than grateful. Thank you -- Trish -- Dave Peterson -- Dave Peterson |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
stuck in loop
Hi Dave,
Hope you are still ok to help me - much appreciated Could my problem have been that I'm running the code and the workbooks on my memory stick? I've been running the code all evening to try to give you as much detail as possible but I've just run it from my c drive and it ran fine. I'm going to have another couple of tries with different folders etc. Thank you -- Trish "Dave Peterson" wrote: Maybe you could give more details on the problems you're having. If you step through the code (hitting F8), do you see what's happening? Trish Smith wrote: Hi Dave, Thanks for replying. Still having problems and I know this should not be happening. When the code was commented out it behaved perfectly. It went into each workbook and showed the name in the message box and then stopped where it should. When I uncommented the code it got stuck once again. If you can help that would be more than brilliant. Thank you -- Trish "Dave Peterson" wrote: Since you're passing myWB to that subroutine, you don't need to rely on the activeworkbook. But I don't see anything in the snippet of code that would cause a loop. This worked fine for me: Option Compare Text Option Explicit Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 Private Const BIF_RETURNFSANCESTORS As Long = &H8 Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 Private Const BIF_BROWSEFORPRINTER As Long = &H2000 Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 Private Const MAX_PATH As Long = 260 Type BrowseInfo hOwner As Long pidlRoot As Long pszDisplayName As String lpszINSTRUCTIONS As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Boolean hNameMappings As Long lpszProgressTitle As String End Type Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _ ByVal pidl As Long, _ ByVal pszBuffer As String) As Long Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _ lpBrowseInfo As BrowseInfo) As Long Function BrowseFolder(Optional Caption As String = "") As String Dim BrowseInfo As BrowseInfo Dim FolderName As String Dim ID As Long Dim Res As Long With BrowseInfo .hOwner = 0 .pidlRoot = 0 .pszDisplayName = String$(MAX_PATH, vbNullChar) .lpszINSTRUCTIONS = Caption .ulFlags = BIF_RETURNONLYFSDIRS .lpfn = 0 End With FolderName = String$(MAX_PATH, vbNullChar) ID = SHBrowseForFolderA(BrowseInfo) If ID Then Res = SHGetPathFromIDListA(ID, FolderName) If Res Then BrowseFolder = Left$(FolderName, InStr(FolderName, _ vbNullChar) - 1) End If End If End Function Sub test() Dim myWB As Workbook Dim AutoSecurity As MsoAutomationSecurity 'Dim mymyPath As String Dim myName As String Dim myPath As String Dim Prompt As String Dim Title As String myPath = BrowseFolder("Select A Folder") If myPath = "" Then Prompt = "You didn't select a folder. The procedure has been canceled." Title = "Procedure Canceled" MsgBox Prompt, vbCritical, Title Else Prompt = "You selected the following myPath:" & vbNewLine & myPath Title = "Procedure Completed" MsgBox Prompt, vbInformation, Title If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If myName = Dir(myPath & "*.xls") If myName < "" Then Do Debug.Print myName AutoSecurity = Application.AutomationSecurity Application.AutomationSecurity = msoAutomationSecurityLow Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If End Sub Sub CopyTemplates(myWB As Workbook) 'just for testing MsgBox myWB.FullName ' ThisWorkbook.Worksheets(Array("Datasheet1", _ ' "Datasheet2", _ ' "Datasheet3", _ ' "Charts1", _ ' "Charts2", _ ' "Charts3", _ ' "Summary")).Copy _ ' Befo=myWB.Worksheets(1) ' myWB.Close savechanges:=True End Sub If you see the names correctly, then delete that line and uncomment the .copy line(s). Trish Smith wrote: Hi all, I've altered the code for browse and protect that Dave Peterson helped me with and now it gets stuck in a loop. The original code looped though all workbooks in browsed for folder and then looped through all worksheets with a for each loop. I altered the code to do a different job. What I wanted to do was copy an array of sheets from the workbook with the code to all the workbooks in the folder. Here's the bits of code This is the end of the browse for filename code Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If Next End Sub This is the bit that replaced the for each unprotect Sub CopyTemplates (myWB As Workbook) Set myWB = ActiveWorkbook ThisWorkbook.Worksheets(Array("Datasheet1", "Datasheet2", "Datasheet3", _ "Charts1", "Charts2", "Charts3", "Summary")).Copy _ Befo=myWB.Worksheets(1) myWB.Close savechanges:=True End Sub If anyone could tell me what's missing please, I'd be more than grateful. Thank you -- Trish -- Dave Peterson -- Dave Peterson |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
stuck in loop
First, I would never edit a document directly from a memory stick (or any
removeable media). Maybe the program just slowed down to a crawl. Those memory sticks are lots, lots slower than harddrives. As an aside, I had a program that opened a bunch of files that were stored on a Network drive. It would take hours (ok 30-45 minutes) to run. I could copy all the workbooks to my C: drive and it would run in a couple of minutes. Even adding that extra step of copying the files first didn't make the overall time more than 5-10 minutes. Trish Smith wrote: Hi Dave, Hope you are still ok to help me - much appreciated Could my problem have been that I'm running the code and the workbooks on my memory stick? I've been running the code all evening to try to give you as much detail as possible but I've just run it from my c drive and it ran fine. I'm going to have another couple of tries with different folders etc. Thank you -- Trish "Dave Peterson" wrote: Maybe you could give more details on the problems you're having. If you step through the code (hitting F8), do you see what's happening? Trish Smith wrote: Hi Dave, Thanks for replying. Still having problems and I know this should not be happening. When the code was commented out it behaved perfectly. It went into each workbook and showed the name in the message box and then stopped where it should. When I uncommented the code it got stuck once again. If you can help that would be more than brilliant. Thank you -- Trish "Dave Peterson" wrote: Since you're passing myWB to that subroutine, you don't need to rely on the activeworkbook. But I don't see anything in the snippet of code that would cause a loop. This worked fine for me: Option Compare Text Option Explicit Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 Private Const BIF_RETURNFSANCESTORS As Long = &H8 Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 Private Const BIF_BROWSEFORPRINTER As Long = &H2000 Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 Private Const MAX_PATH As Long = 260 Type BrowseInfo hOwner As Long pidlRoot As Long pszDisplayName As String lpszINSTRUCTIONS As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Boolean hNameMappings As Long lpszProgressTitle As String End Type Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _ ByVal pidl As Long, _ ByVal pszBuffer As String) As Long Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _ lpBrowseInfo As BrowseInfo) As Long Function BrowseFolder(Optional Caption As String = "") As String Dim BrowseInfo As BrowseInfo Dim FolderName As String Dim ID As Long Dim Res As Long With BrowseInfo .hOwner = 0 .pidlRoot = 0 .pszDisplayName = String$(MAX_PATH, vbNullChar) .lpszINSTRUCTIONS = Caption .ulFlags = BIF_RETURNONLYFSDIRS .lpfn = 0 End With FolderName = String$(MAX_PATH, vbNullChar) ID = SHBrowseForFolderA(BrowseInfo) If ID Then Res = SHGetPathFromIDListA(ID, FolderName) If Res Then BrowseFolder = Left$(FolderName, InStr(FolderName, _ vbNullChar) - 1) End If End If End Function Sub test() Dim myWB As Workbook Dim AutoSecurity As MsoAutomationSecurity 'Dim mymyPath As String Dim myName As String Dim myPath As String Dim Prompt As String Dim Title As String myPath = BrowseFolder("Select A Folder") If myPath = "" Then Prompt = "You didn't select a folder. The procedure has been canceled." Title = "Procedure Canceled" MsgBox Prompt, vbCritical, Title Else Prompt = "You selected the following myPath:" & vbNewLine & myPath Title = "Procedure Completed" MsgBox Prompt, vbInformation, Title If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If myName = Dir(myPath & "*.xls") If myName < "" Then Do Debug.Print myName AutoSecurity = Application.AutomationSecurity Application.AutomationSecurity = msoAutomationSecurityLow Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If End Sub Sub CopyTemplates(myWB As Workbook) 'just for testing MsgBox myWB.FullName ' ThisWorkbook.Worksheets(Array("Datasheet1", _ ' "Datasheet2", _ ' "Datasheet3", _ ' "Charts1", _ ' "Charts2", _ ' "Charts3", _ ' "Summary")).Copy _ ' Befo=myWB.Worksheets(1) ' myWB.Close savechanges:=True End Sub If you see the names correctly, then delete that line and uncomment the .copy line(s). Trish Smith wrote: Hi all, I've altered the code for browse and protect that Dave Peterson helped me with and now it gets stuck in a loop. The original code looped though all workbooks in browsed for folder and then looped through all worksheets with a for each loop. I altered the code to do a different job. What I wanted to do was copy an array of sheets from the workbook with the code to all the workbooks in the folder. Here's the bits of code This is the end of the browse for filename code Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If Next End Sub This is the bit that replaced the for each unprotect Sub CopyTemplates (myWB As Workbook) Set myWB = ActiveWorkbook ThisWorkbook.Worksheets(Array("Datasheet1", "Datasheet2", "Datasheet3", _ "Charts1", "Charts2", "Charts3", "Summary")).Copy _ Befo=myWB.Worksheets(1) myWB.Close savechanges:=True End Sub If anyone could tell me what's missing please, I'd be more than grateful. Thank you -- Trish -- Dave Peterson -- Dave Peterson -- Dave Peterson |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
stuck in loop
Hi Dave,
Thanks for your help. If you hadn't confirmed that the code was ok I would still have been plugging away googling options and making changes. I'll stay clear of the stick from now on! Thank you -- Trish "Dave Peterson" wrote: First, I would never edit a document directly from a memory stick (or any removeable media). Maybe the program just slowed down to a crawl. Those memory sticks are lots, lots slower than harddrives. As an aside, I had a program that opened a bunch of files that were stored on a Network drive. It would take hours (ok 30-45 minutes) to run. I could copy all the workbooks to my C: drive and it would run in a couple of minutes. Even adding that extra step of copying the files first didn't make the overall time more than 5-10 minutes. Trish Smith wrote: Hi Dave, Hope you are still ok to help me - much appreciated Could my problem have been that I'm running the code and the workbooks on my memory stick? I've been running the code all evening to try to give you as much detail as possible but I've just run it from my c drive and it ran fine. I'm going to have another couple of tries with different folders etc. Thank you -- Trish "Dave Peterson" wrote: Maybe you could give more details on the problems you're having. If you step through the code (hitting F8), do you see what's happening? Trish Smith wrote: Hi Dave, Thanks for replying. Still having problems and I know this should not be happening. When the code was commented out it behaved perfectly. It went into each workbook and showed the name in the message box and then stopped where it should. When I uncommented the code it got stuck once again. If you can help that would be more than brilliant. Thank you -- Trish "Dave Peterson" wrote: Since you're passing myWB to that subroutine, you don't need to rely on the activeworkbook. But I don't see anything in the snippet of code that would cause a loop. This worked fine for me: Option Compare Text Option Explicit Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 Private Const BIF_RETURNFSANCESTORS As Long = &H8 Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 Private Const BIF_BROWSEFORPRINTER As Long = &H2000 Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 Private Const MAX_PATH As Long = 260 Type BrowseInfo hOwner As Long pidlRoot As Long pszDisplayName As String lpszINSTRUCTIONS As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Boolean hNameMappings As Long lpszProgressTitle As String End Type Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _ ByVal pidl As Long, _ ByVal pszBuffer As String) As Long Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _ lpBrowseInfo As BrowseInfo) As Long Function BrowseFolder(Optional Caption As String = "") As String Dim BrowseInfo As BrowseInfo Dim FolderName As String Dim ID As Long Dim Res As Long With BrowseInfo .hOwner = 0 .pidlRoot = 0 .pszDisplayName = String$(MAX_PATH, vbNullChar) .lpszINSTRUCTIONS = Caption .ulFlags = BIF_RETURNONLYFSDIRS .lpfn = 0 End With FolderName = String$(MAX_PATH, vbNullChar) ID = SHBrowseForFolderA(BrowseInfo) If ID Then Res = SHGetPathFromIDListA(ID, FolderName) If Res Then BrowseFolder = Left$(FolderName, InStr(FolderName, _ vbNullChar) - 1) End If End If End Function Sub test() Dim myWB As Workbook Dim AutoSecurity As MsoAutomationSecurity 'Dim mymyPath As String Dim myName As String Dim myPath As String Dim Prompt As String Dim Title As String myPath = BrowseFolder("Select A Folder") If myPath = "" Then Prompt = "You didn't select a folder. The procedure has been canceled." Title = "Procedure Canceled" MsgBox Prompt, vbCritical, Title Else Prompt = "You selected the following myPath:" & vbNewLine & myPath Title = "Procedure Completed" MsgBox Prompt, vbInformation, Title If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If myName = Dir(myPath & "*.xls") If myName < "" Then Do Debug.Print myName AutoSecurity = Application.AutomationSecurity Application.AutomationSecurity = msoAutomationSecurityLow Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If End Sub Sub CopyTemplates(myWB As Workbook) 'just for testing MsgBox myWB.FullName ' ThisWorkbook.Worksheets(Array("Datasheet1", _ ' "Datasheet2", _ ' "Datasheet3", _ ' "Charts1", _ ' "Charts2", _ ' "Charts3", _ ' "Summary")).Copy _ ' Befo=myWB.Worksheets(1) ' myWB.Close savechanges:=True End Sub If you see the names correctly, then delete that line and uncomment the .copy line(s). Trish Smith wrote: Hi all, I've altered the code for browse and protect that Dave Peterson helped me with and now it gets stuck in a loop. The original code looped though all workbooks in browsed for folder and then looped through all worksheets with a for each loop. I altered the code to do a different job. What I wanted to do was copy an array of sheets from the workbook with the code to all the workbooks in the folder. Here's the bits of code This is the end of the browse for filename code Set myWB = Workbooks.Open(myPath & myName) Call CopyTemplates(myWB) Application.AutomationSecurity = AutoSecurity On Error Resume Next myName = Dir ' Get next entry. If myName = "" Then Exit Do End If Loop End If End If Next End Sub This is the bit that replaced the for each unprotect Sub CopyTemplates (myWB As Workbook) Set myWB = ActiveWorkbook ThisWorkbook.Worksheets(Array("Datasheet1", "Datasheet2", "Datasheet3", _ "Charts1", "Charts2", "Charts3", "Summary")).Copy _ Befo=myWB.Worksheets(1) myWB.Close savechanges:=True End Sub If anyone could tell me what's missing please, I'd be more than grateful. Thank you -- Trish -- Dave Peterson -- Dave Peterson -- Dave Peterson |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
stuck in an error loop | Excel Discussion (Misc queries) | |||
stuck at a loop | Excel Programming | |||
Stuck in a Sub Loop | Excel Worksheet Functions | |||
Stuck in a loop | Excel Discussion (Misc queries) | |||
HELP - Stuck in loop | Excel Programming |