Problem executing VBA

goldenvision

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

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Sort by date Sort by votes
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
Click to expand...

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)
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
VBA to stop writing to specific sheet based on user selection
Replies
1
Views
361
Paul15
P
M
  • Question Question
How To Loop Macro
Replies
6
Views
438
rlv01
R
M
  • Question Question
Macro - find (control+f) value copied earlier in process
Replies
9
Views
298
Alex Blakenburg
A
R
  • Solved
Filter data set to #N/A, skip step entirely if none
Replies
3
Views
252
RoryA
RoryA
D
  • Solved
VBA If statement to continue
2
Replies
17
Views
513
dinunan
D

Forum statistics

Threads
1,222,229
Messages
6,164,733
Members
451,911
Latest member
HMF009

Share this page

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
Back
Top