|
-
Mar 6th, 2014, 09:41 AM
#39
Thread Starter
Junior Member
Re: Excel 2010 freezing when renaming multiple sheets
Ok, here is the final product just so you guys have closure. I added the reset counter code to reset after reaching 8 (thanks TnTinMN!!!!) and it works beautifully. That was a problem I've been working on for months here and there but finally decided to put my full attention to it until I figured it out. I couldn't have done it without you guys!!! Thanks so much! I guess the cache was the problem here. If you have a macro that does a lot of cutting and pasting of large amounts of data and it freezes, you will need to clear the cache every so often to fix the freezing. Learned a lot on this one!!
Sub Update_Client_Tabs()
Dim wb As Workbook
Dim wsStart As Worksheet
Dim rng As Range
Set wb = ActiveWorkbook
Set wsStart = wb.Worksheets("Start Tab")
Set rng = Range(wsStart.Range("f7"), wsStart.Range("f7").End(xlDown))
Dim counter As Integer
counter = 1
Sheets("Start Tab").Range("F7").Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
sourcesheet = ActiveSheet.Name
For Each Cell In Selection
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Cell.Value
Range("A1").FormulaR1C1 = _
"=MID(CELL(""filename"",RC),FIND(""]"",CELL(""filename"",RC))+1,256)"
Range("B1").FormulaR1C1 = _
"=INDEX('Start Tab'!C6:C9,MATCH(R1C1,'Start Tab'!C6,0),4)"
Range("B1").Copy
Range("B2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").FormulaR1C1 = "=IF(RC[1]="""","""",R1C1)"
Range("A2").AutoFill Destination:=Range("A2:A1000"), Type:=xlFillDefault
Range("A2:A1000").FillDown
On Error Resume Next
Dim sURL As String
Dim qtsQueries As QueryTables
Dim qtQuery As QueryTable
Set qtsQueries = ActiveSheet.QueryTables
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Range("B2").Value, _
Destination:=ActiveSheet.Range("b4"))
.Name = Range("B2").Value
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
If Err.Number <> 0 Then
MsgBox Err.Description
Stop
Exit Sub
End If
Range("a2").Select
Range("$A$2:$A$1000").Copy
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("3:3").Select
ActiveWindow.FreezePanes = True
Range("A4").Buttons.Add(800, 5, 45, 25).OnAction = "Back"
ActiveSheet.Shapes("Button 1").Characters.Text = "Back"
Range("C1").FormulaR1C1 = _
"=MID(CELL(""filename"",RC[-2]),FIND(""]"",CELL(""Filename"",RC[-2]))+1,256)"
Worksheets(Worksheets.Count).Sheets(sourcesheet).Activate
counter = counter + 1
If counter > 8 Then
counter = 1
Shell "RunDll32.exe InetCpl.Cpl, ClearMyTracksByProcess 11"
End If
Next
Sheets("Start Tab").Select
End Sub
Tags for this Thread
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|