Problem executing VBA

goldenvision

Board Regular
Joined
Jan 13, 2004
Messages
234
I am having problems with the below code. It runs fine but after about 1000 records the spreadsheet disappears and I get a plain white screen until it finishes and then excel appears again.

I suspect it has something to do with the amount of resource is requires.

Any clues how I can streamline the code?


Code:
Sub SplitByManuf()
Dim rowcount As Integer
Dim cAV, cBF, cBR, cCA, cCO, cCR, cCU, cDU, cEN, cFE, cFI, cGE, cGO, cHA, cKL, cKU, cLA, cMA, cMD, cMX, cMI, cNA, cPI, cRI, cSE, cST, cTR, cUN, cVR, cYO As Integer
Dim PctDone As Integer

Application.ScreenUpdating = False

Sheets("(Mis)Match").Select

'specify start point
rowcount = 1
cAV = 2
cBF = 2
cBR = 2
cCA = 2
cCO = 2
cCR = 2
cCU = 2
cDU = 2
cEN = 2
cFE = 2
cFI = 2
cGE = 2
cGO = 2
cHA = 2
cKL = 2
cKU = 2
cLA = 2
cMA = 2
cMD = 2
cMX = 2
cMI = 2
cNA = 2
cPI = 2
cRI = 2
cSE = 2
cST = 2
cTR = 2
cUN = 2
cVR = 2
cYO = 2

Do Until Cells(rowcount, 1) = ""

Select Case Cells(rowcount, 8).Value
    Case "AV"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("AV").Select
        Range("A" & cAV).Select
        ActiveSheet.Paste
        Range("A1").Select
        cAV = cAV + 1
        Sheets("(Mis)Match").Select
    Case "BF"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("BF").Select
        Range("A" & cBF).Select
        ActiveSheet.Paste
        Range("A1").Select
        cBF = cBF + 1
        Sheets("(Mis)Match").Select
    Case "BR"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("BR").Select
        Range("A" & cBR).Select
        ActiveSheet.Paste
        Range("A1").Select
        cBR = cBR + 1
        Sheets("(Mis)Match").Select
    Case "CA"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("CA").Select
        Range("A" & cCA).Select
        ActiveSheet.Paste
        Range("A1").Select
        cCA = cCA + 1
        Sheets("(Mis)Match").Select
    Case "CO"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("CO").Select
        Range("A" & cCO).Select
        ActiveSheet.Paste
        Range("A1").Select
        cCO = cCO + 1
        Sheets("(Mis)Match").Select
    Case "CR"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("CR").Select
        Range("A" & cCR).Select
        ActiveSheet.Paste
        Range("A1").Select
        cCR = cCR + 1
        Sheets("(Mis)Match").Select
    Case "CU"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("CU").Select
        Range("A" & cCU).Select
        ActiveSheet.Paste
        Range("A1").Select
        cCU = cCU + 1
        Sheets("(Mis)Match").Select
    Case "DU"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("DU").Select
        Range("A" & cDU).Select
        ActiveSheet.Paste
        Range("A1").Select
        cDU = cDU + 1
        Sheets("(Mis)Match").Select
    Case "EN"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("EN").Select
        Range("A" & cEN).Select
        ActiveSheet.Paste
        Range("A1").Select
        cEN = cEN + 1
        Sheets("(Mis)Match").Select
    Case "FE"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("FE").Select
        Range("A" & cFE).Select
        ActiveSheet.Paste
        Range("A1").Select
        cFE = cFE + 1
        Sheets("(Mis)Match").Select
    Case "FI"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("FI").Select
        Range("A" & cFI).Select
        ActiveSheet.Paste
        Range("A1").Select
        cFI = cFI + 1
        Sheets("(Mis)Match").Select
    Case "GE"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("GE").Select
        Range("A" & cGE).Select
        ActiveSheet.Paste
        Range("A1").Select
        cGE = cGE + 1
        Sheets("(Mis)Match").Select
    Case "GO"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("GO").Select
        Range("A" & cGO).Select
        ActiveSheet.Paste
        Range("A1").Select
        cGO = cGO + 1
        Sheets("(Mis)Match").Select
    Case "HA"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("HA").Select
        Range("A" & cHA).Select
        ActiveSheet.Paste
        Range("A1").Select
        cHA = cHA + 1
        Sheets("(Mis)Match").Select
    Case "KL"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("KL").Select
        Range("A" & cKL).Select
        ActiveSheet.Paste
        Range("A1").Select
        cKL = cKL + 1
        Sheets("(Mis)Match").Select
    Case "KU"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("KU").Select
        Range("A" & cKU).Select
        ActiveSheet.Paste
        Range("A1").Select
        cKU = cKU + 1
        Sheets("(Mis)Match").Select
    Case "LA"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("LA").Select
        Range("A" & cLA).Select
        ActiveSheet.Paste
        Range("A1").Select
        cLA = cLA + 1
        Sheets("(Mis)Match").Select
    Case "MA"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("MA").Select
        Range("A" & cMA).Select
        ActiveSheet.Paste
        Range("A1").Select
        cMA = cMA + 1
        Sheets("(Mis)Match").Select
    Case "MD"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("MD").Select
        Range("A" & cMD).Select
        ActiveSheet.Paste
        Range("A1").Select
        cMD = cMD + 1
        Sheets("(Mis)Match").Select
    Case "MX"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("MX").Select
        Range("A" & cMX).Select
        ActiveSheet.Paste
        Range("A1").Select
        cMX = cMX + 1
        Sheets("(Mis)Match").Select
    Case "MI"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("MI").Select
        Range("A" & cMI).Select
        ActiveSheet.Paste
        Range("A1").Select
        cMI = cMI + 1
        Sheets("(Mis)Match").Select
    Case "NA"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("NA").Select
        Range("A" & cNA).Select
        ActiveSheet.Paste
        Range("A1").Select
        cNA = cNA + 1
        Sheets("(Mis)Match").Select
    Case "PI"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("PI").Select
        Range("A" & cPI).Select
        ActiveSheet.Paste
        Range("A1").Select
        cPI = cPI + 1
        Sheets("(Mis)Match").Select
    Case "RI"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("RI").Select
        Range("A" & cRI).Select
        ActiveSheet.Paste
        Range("A1").Select
        cRI = cRI + 1
        Sheets("(Mis)Match").Select
    Case "SE"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("SE").Select
        Range("A" & cSE).Select
        ActiveSheet.Paste
        Range("A1").Select
        cSE = cSE + 1
        Sheets("(Mis)Match").Select
    Case "ST"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("ST").Select
        Range("A" & cST).Select
        ActiveSheet.Paste
        Range("A1").Select
        cST = cST + 1
        Sheets("(Mis)Match").Select
    Case "TR"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("TR").Select
        Range("A" & cTR).Select
        ActiveSheet.Paste
        Range("A1").Select
        cTR = cTR + 1
        Sheets("(Mis)Match").Select
    Case "UN"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("UN").Select
        Range("A" & cUN).Select
        ActiveSheet.Paste
        Range("A1").Select
        cUN = cUN + 1
        Sheets("(Mis)Match").Select
    Case "VR"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("VR").Select
        Range("A" & cVR).Select
        ActiveSheet.Paste
        Range("A1").Select
        cVR = cVR + 1
        Sheets("(Mis)Match").Select
    Case "YO"
        Rows(rowcount & ":" & rowcount).Select
        Selection.Copy
        Sheets("YO").Select
        Range("A" & cYO).Select
        ActiveSheet.Paste
        Range("A1").Select
        cYO = cYO + 1
        Sheets("(Mis)Match").Select
    Case Else

End Select
rowcount = rowcount + 1
'PctDone = rowcount / 8049 * 100
Application.StatusBar = "Processed " & rowcount & "of 8150 Records"
Loop
Application.StatusBar = False
End Sub
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

njimack

Well-known Member
Joined
Jun 17, 2005
Messages
7,764
I'm having some trouble understanding what you're trying to do, but you should avoid selecting cells to start with. Something like...

Code:
Case "AV" 
        Rows(rowcount & ":" & rowcount).Copy Destination:=Sheets("AV"). Range("A" & cAV)
        cAV = cAV + 1
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,329
Office Version
  1. 365
Platform
  1. Windows
What is this code actually meant to do?

If I'm reading it correctly it's seperating data out into seperate sheets based on the value in column 8.

If that's the case you could probably do it with advanced filter.

Here's an example of what I mean.
Code:
Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
    
    Set wsAll = Worksheets("(Mis)Match")
    
    LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
    Set wsCrit = Worksheets.Add
    
    ' get all the unique values in column H(8)
    wsAll.Range("H1:H" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LastRowCrit
    
        wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
         CopyToRange:=Worksheets(wsCrit.Range("A2").Value).Range("A1"), Unique:=False
        wsCrit.Rows(2).Delete
    Next I
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub
 

Jonmo1

MrExcel MVP
Joined
Oct 12, 2006
Messages
44,061
2 things you can do,

1st. Turn Screenupdating OFF
Code:
application.screenupdating = false

rest of code here

application.screenupdating = true

that makes it not flash the screens at all...

2nd. Don't use select, your code will run MUCH MUCH Faster...

For example, you can do this to each Case Statement...

this
Code:
    Case "AV" 
        Rows(rowcount & ":" & rowcount).Select 
        Selection.Copy 
        Sheets("AV").Select 
        Range("A" & cAV).Select 
        ActiveSheet.Paste 
        Range("A1").Select 
        cAV = cAV + 1 
        Sheets("(Mis)Match").Select

Can be changed to
Code:
    Case "AV" 
        Rows(rowcount & ":" & rowcount).Copy Sheets("AV").Range("A" & cAV)
        cAV = cAV + 1
 

goldenvision

Board Regular
Joined
Jan 13, 2004
Messages
234
What is this code actually meant to do?

If I'm reading it correctly it's seperating data out into seperate sheets based on the value in column 8.

If that's the case you could probably do it with advanced filter.

Here's an example of what I mean.
Code:
Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
    
    Set wsAll = Worksheets("(Mis)Match")
    
    LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
    Set wsCrit = Worksheets.Add
    
    ' get all the unique values in column H(8)
    wsAll.Range("H1:H" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LastRowCrit
    
        wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
         CopyToRange:=Worksheets(wsCrit.Range("A2").Value).Range("A1"), Unique:=False
        wsCrit.Rows(2).Delete
    Next I
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub

Could the concept behind this VBA be incorporated into another project I am working on. See here (http://www.mrexcel.com/board2/viewtopic.php?t=276945&start=0)
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,102
Messages
5,768,102
Members
425,454
Latest member
khoro

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top