PDA

View Full Version : [SOLVED] Annoying VBA



Paleo
01-08-2005, 04:58 PM
Hi people,

I am having an annoying VBA problem. I have a spreadsheet that has many Subs on its 52 Mb and uses data from another worksheet that has 48 Mb and a text file that has another 11 Mb.

I have a VBA code that works fine on it but is TOO slow:


Sub Test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
aNome = ActiveSheet.Name
Nova = "NC_" & Right(aNome, 3)
Dim i As Long, n As Long
n = 2
Range("A1").EntireRow.Copy Sheets(Nova).Range("A1")
For i = Range("A65536").End(xlUp).Row To 1 Step -1
If Range("A" & i).Value = "NC" Then
Range("A" & i).EntireRow.Copy Sheets(Nova).Range("A" & n)
n = n + 1
Range("C" & i).EntireRow.Delete
End If
Next i
Sheets(Nova).Activate
Range("A1:F21").Select
End Sub


And when I try to modify it to make it faster, using the code below I get an error 1004 message, telling me an error occurred at the copy function from the range class.


Sub test2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
aNome = ActiveSheet.Name
Nova = "NC_" & Right(aNome, 3)
Dim filterRng As Range
Set filterRng = Nothing
With Sheets(aNome)
Set filterRng = .Range("A1", .Range("K65536").End(xlUp))
With filterRng
.AutoFilter field:=1, Criteria1:="=NC"
.SpecialCells(xlCellTypeVisible).Copy Sheets(Nova).Range("A1")
.SpecialCells(xlCellTypeVisible).Delete
.Cells(1).EntireRow.Insert
End With
Sheets(Nova).Range("1:1").Copy .Range("1:1")
End With
Set filterRng = Nothing
Sheets(Nova).Activate
ActiveWorkbook.Names.Add Name:="tblNC", RefersToR1C1:="=NC_nov!R1C1:R21C6"
Range("A1").Select
Sheets(aNome).Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


The interesting part is that I get that error AFTER it has copied all the cells.
:dunno :dunno :dunno :dunno
So, does anyone knows whats going on? May anyone help me out, please?
:help :help :help :help

Jacob Hilderbrand
01-08-2005, 05:16 PM
You can't post html code. Just regular text, bbcode (http://www.vbaexpress.com/forum/misc.php?do=bbcode), and you can also post an attachment.

Paleo
01-08-2005, 05:19 PM
Hi Jacob,

sorry. I have edited my post.

Jacob Hilderbrand
01-08-2005, 06:12 PM
Ok, it looks much better now. Also if you are going to cross post to different forums please provide a link. That way people don't waste their time posting if you already got an answer somewhere else.

http://www.mrexcel.com/board2/viewtopic.php?t=123948&sid=ec020493a09e2e97c08a24176b4bc2d8

Jacob Hilderbrand
01-08-2005, 06:51 PM
See if this works for you.


Sub test2()
Dim filterRng As Range
Dim LastRow As Long
Dim Nova As String
Dim Nome As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
aNome = ActiveSheet.Name
Nova = "NC_" & Right(aNome, 3)
Set filterRng = Nothing
LastRow = Sheets(aNome).Range("K65536").End(xlUp).Row
Set filterRng = Sheets(aNome).Range("A1:A" & LastRow)
With filterRng
.AutoFilter field:=1, Criteria1:="=NC"
.SpecialCells(xlCellTypeVisible).Copy Sheets(Nova).Range("A1")
.SpecialCells(xlCellTypeVisible).Delete
.Cells(1).EntireRow.Insert
End With
Sheets(Nova).Range("1:1").Copy Sheets(aNome).Range("1:1")
Set filterRng = Nothing
Sheets(Nova).Activate
ActiveWorkbook.Names.Add Name:="tblNC", RefersToR1C1:="=NC_nov!R1C1:R21C6"
Range("A1").Select
Sheets(aNome).Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Paleo
01-08-2005, 07:47 PM
Hi Jacob,

nope, didnt work at all. But I just have found a solution that worked out.

I copy it here to help more people. Thanks for the support.


Sub Test()
aNome = ActiveSheet.Name
Nova = "NC_" & Right(aNome, 3)
Dim rng As Range
Columns(1).Insert
Set rng = Range([A2], [B65536].End(xlUp)(1, 0))
With rng
.FormulaR1C1 = "=IF(RC[1]=""NC"",""d"",1)"
.EntireRow.Sort Key1:=[A2], Order1:=xlAscending, Header:=xlNo
On Error Resume Next
.SpecialCells(xlCellTypeFormulas, 2).EntireRow.Cut Sheets(Nova).[A2]
On Error GoTo 0
.EntireColumn.Delete
End With
Sheets(Nova).Columns(1).Delete
Rows(1).Copy Sheets(Nova).Rows(1)
End Sub

Jacob Hilderbrand
01-08-2005, 07:54 PM
Glad you got it working. I also editted your posts to use VBA tags. That way the VBA code appears as it would in the VBE which is a pretty nice feature.

To do that just put (VBA) at the beginning of your code and (/VBA) at the end. When you really do this use square brackets [ ] though.

Paleo
01-08-2005, 08:26 PM
Thanks Jacob!

Sorry for the VBA, I still learning how to use this forum, but I must tell that I liked it a lot!

Zack Barresse
01-08-2005, 10:48 PM
Ok, it looks much better now. Also if you are going to cross post to different forums please provide a link. That way people don't waste their time posting if you already got an answer somewhere else.

http://www.mrexcel.com/board2/viewtopic.php?t=123948&sid=ec020493a09e2e97c08a24176b4bc2d8

Also here: http://www.mrexcel.com/board2/viewtopic.php?t=122970

Glad you got it working Paleo. :yes

Paleo
01-09-2005, 08:02 AM
Thanks Zack,

Ok, I will always put a link when a cross post. Sorry, I didnt think I should do that, because it could be considered wrong. You know, it could be considered as marketing another forum.

By the way, as I have liked more that first solution of yours I have just adapted it and got it working just fine.

Here is its final code:


Option Explicit

Sub TestForMrE()
Dim aNome As String, Nova As String, filterRng As Range, nommes As String
While (Len(nommes) > 3) Or nommes = ""
nommes = InputBox("Type month's name with 3 characters", "Report Month", _
"jan, feb, mar, apr, mai, jun, jul, aug, sep, oct, nov, dec")
Wend
Application.ScreenUpdating = False
Application.DisplayAlerts = False
aNome = "can_" & LCase(nommes)
Nova = "NC_" & LCase(nommes)
ActiveSheet.Name = aNome
Sheets.Add
ActiveSheet.Name = Nova
With Sheets(aNome)
'.Range("A1").EntireRow.Copy Sheets(Nova).Range("A1")
Set filterRng = .Range("A1", .Range("D65536").End(xlUp))
With filterRng
.AutoFilter field:=1, Criteria1:="=NC"
On Error Resume Next
.SpecialCells(xlCellTypeVisible).Copy Sheets(Nova).Range("A2")
.SpecialCells(xlCellTypeVisible).Delete
.Cells(1).EntireRow.Insert
End With
Sheets(Nova).Range("1:1").Copy .Range("1:1")
End With
Sheets(Nova).Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub