Hi,
While I am executing the attached script, excel is hanging at some point (Data For AAX7 / Data For AAX8). Please let me know what can I do to avoid this scenario. Your help on this issues is much appreciated.
I think this issue is happening at the time of copying the data after filtering. It looks like, It has lot many rows to copy and paste; may be that's why it is hanging. More over when I am executing the each line step by step I am not getting any issue.
Regards,
Sri
Re: VBA Code: excel is hanging at some point
MODERATOR NOTICE: This topic has also been posted on other sites and may already have an answer elsewhere. Please take this into consideration when answering this question
*
Re: VBA Code: excel is hanging at some point
Both the way you can complete your task, please try.
Option Explicit
Sub Test()
Dim Rng As Range, A As Variant, e As Variant, sht As Worksheet, n As Long, i As Long
On Error Resume Next
Set sht = ThisWorkbook.Sheets("Dispatch_load")
If sht Is Nothing Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Dispatch_load"
End If
n = 10: i = 0
With Sheets("AMC Agent Breakout")
.Activate
For Each e In Array("KAX0", "KAX1", "KAX2", "KAX3", "KAX4", "KAX5", "KAX6", "KAX7", "KAX8", "KAX9")
.Range("A1:R" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=8, Criteria1:=e
.Range("A1:R" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=18, Criteria1:="0"
Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1, .AutoFilter.Range.Columns.Count) _
.SpecialCells(xlCellTypeVisible)
If Not Rng Is Nothing Then
On Error Resume Next
Set sht = ThisWorkbook.Sheets("Agent&DRM")
If sht Is Nothing Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Agent&DRM"
End If
With Sheets("Agent&DRM")
.Activate
Rng.Copy .Range("C6")
.Columns("C:I").Delete Shift:=xlToLeft
.Columns("D:J").Delete Shift:=xlToLeft
.Columns("E:F").Delete Shift:=xlToLeft
.Range("T17").FormulaR1C1 = "AAX" & i
.Range("U17").FormulaR1C1 = "=SUM(R[-11]C[-17]:R[8983]C[-17])"
.Range("T17:U17").Copy
Sheets("Dispatch_load").Range("A" & n).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
End If
n = n + 1: i = i + 1
.AutoFilterMode = False
Next
End With
End Sub
Sub Test1()
Dim Rng As Range, Rng1 As Range, rng2 As Range
Dim sht As Worksheet
On Error Resume Next
Set sht = ThisWorkbook.Sheets("Dispatch_load")
If sht Is Nothing Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Dispatch_load"
End If
With Sheets("AMC Agent Breakout")
.Range("A1:R" & .UsedRange.Rows.Count).AutoFilter Field:=8, Criteria1:="=KAX*"
.Range("A1:R" & .UsedRange.Rows.Count).AutoFilter Field:=18, Criteria1:="=0"
On Error Resume Next
Set Rng = .AutoFilter.Range.Offset(1, 7).Resize(.AutoFilter.Range.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
Set Rng1 = .AutoFilter.Range.Offset(1, 15).Resize(.AutoFilter.Range.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
Set rng2 = Union(Rng, Rng1)
If Not rng2 Is Nothing Then
rng2.Copy Sheets("Dispatch_load").Range("A10")
End If
.AutoFilterMode = False
End With
End SubRe: VBA Code: excel is hanging at some point
Hi,
First Function of the code (Test) is working fine. But When I am a particular filtering the combination (KAX7,0 and KAX9,0) of data data sum of all the rows should come as zero. Because as there is no data for KAX7 and KAX9. But I am getting KAX6 sum to KAX7 and KAX8 sum to KAX9. I think, I just need to clear the cells before next combination is getting added and Copied over. Please suggest me on this.
Thank you so much for your help.
Regards,
Sri
Re: VBA Code: excel is hanging at some point
I have added two extra line in the code and this should work, please try.
Sub Test()
Dim Rng As Range, A As Variant, e As Variant, sht As Worksheet, n As Long, i As Long
On Error Resume Next
Set sht = ThisWorkbook.Sheets("Dispatch_load")
If sht Is Nothing Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Dispatch_load"
End If
n = 10: i = 0
With Sheets("AMC Agent Breakout")
.Activate
For Each e In Array("KAX0", "KAX1", "KAX2", "KAX3", "KAX4", "KAX5", "KAX6", "KAX7", "KAX8", "KAX9")
.Range("A1:R" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=8, Criteria1:=e
.Range("A1:R" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=18, Criteria1:="0"
Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1, .AutoFilter.Range.Columns.Count) _
.SpecialCells(xlCellTypeVisible)
If Not Rng Is Nothing Then
On Error Resume Next
Set sht = ThisWorkbook.Sheets("Agent&DRM")
If sht Is Nothing Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Agent&DRM"
End If
With Sheets("Agent&DRM")
.Activate
.UsedRange.Clear
' Added to clear the existing data
Rng.Copy .Range("C6")
.Columns("C:I").Delete Shift:=xlToLeft
.Columns("D:J").Delete Shift:=xlToLeft
.Columns("E:F").Delete Shift:=xlToLeft
.Range("T17").FormulaR1C1 = "AAX" & i
.Range("U17").FormulaR1C1 = "=SUM(R[-11]C[-17]:R[8983]C[-17])"
.Range("T17:U17").Copy
Sheets("Dispatch_load").Range("A" & n).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
n = n + 1: i = i + 1
End If
.AutoFilterMode = False
Set Rng = Nothing
' Newly added to release the memory
Next
End With
End SubRe: VBA Code: excel is hanging at some point
I have added two extra line in the code and this should work, please try.
Sub Test()
Dim Rng As Range, A As Variant, e As Variant, sht As Worksheet, n As Long, i As Long
On Error Resume Next
Set sht = ThisWorkbook.Sheets("Dispatch_load")
If sht Is Nothing Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Dispatch_load"
End If
n = 10: i = 0
With Sheets("AMC Agent Breakout")
.Activate
For Each e In Array("KAX0", "KAX1", "KAX2", "KAX3", "KAX4", "KAX5", "KAX6", "KAX7", "KAX8", "KAX9")
.Range("A1:R" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=8, Criteria1:=e
.Range("A1:R" & .Range("A" & .Rows.Count).End(xlUp).Row).AutoFilter Field:=18, Criteria1:="0"
Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows.Count - 1, .AutoFilter.Range.Columns.Count) _
.SpecialCells(xlCellTypeVisible)
If Not Rng Is Nothing Then
On Error Resume Next
Set sht = ThisWorkbook.Sheets("Agent&DRM")
If sht Is Nothing Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Agent&DRM"
End If
With Sheets("Agent&DRM")
.Activate
.UsedRange.Clear
' Added to clear the existing data
Rng.Copy .Range("C6")
.Columns("C:I").Delete Shift:=xlToLeft
.Columns("D:J").Delete Shift:=xlToLeft
.Columns("E:F").Delete Shift:=xlToLeft
.Range("T17").FormulaR1C1 = "AAX" & i
.Range("U17").FormulaR1C1 = "=SUM(R[-11]C[-17]:R[8983]C[-17])"
.Range("T17:U17").Copy
Sheets("Dispatch_load").Range("A" & n).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
n = n + 1: i = i + 1
End If
.AutoFilterMode = False
Set Rng = Nothing
' added to release the memory
Next
End With
End SubDon’t have an account yet? Register yourself now and be a part of our community!