This code works perfectly. I only have one question, I want to make it so that if there is nothing in cell Q23 that it will not put anything into NCMR Data, and say something... the code is below of what I have, and below it is what I think I need to do to a specific section to work, can someone review and make sure I am on the right path?
Option Explicit
Sub NCMR()
Dim i As Integer
With Application
.ScreenUpdating = False
End With
'Internal NCMR
Dim wsInt As Worksheet
Dim wsNDA As Worksheet
'Copy Ranges
Dim c As Variant
'Paste Ranges
Dim P As Range
'Setting Sheet
Set wsInt = Sheets("NCMR Input")
Set wsNDA = Sheets("NCMR Data")
Set P = wsInt.Range("B61:V61")
With wsInt
c = Array(.Range("B11"), .Range("B14"), .Range("B17"), .Range("B20"), .Range("Q23"), .Range("B23") _
, .Range("Q11"), .Range("Q14"), .Range("Q17"), .Range("Q20"), .Range("R26"), .Range("V23") _
, .Range("V25"), .Range("V27"), .Range("B32"), .Range("B40"), .Range("B46"), .Range("B52") _
, .Range("D58"), .Range("L58"), .Range("V58"))
End With
For i = LBound(c) To UBound(c)
P(i + 1).Value = c(i).Value
Next
With wsNDA
Dim LastRow As Long
LastRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
wsInt.Rows("61").Copy
With .Rows(LastRow)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
.Interior.Pattern = xlNone
End With
With .Range("A" & LastRow)
If LastRow = 3 Then
.Value = 1
Else
.Value = Val(wsNDA.Range("A" & LastRow - 1).Value) + 1
End If
.NumberFormat = "0#######"
End With
End With
With Application
.Range("A61:V61").ClearContents
.ScreenUpdating = True
End With
End Sub
What I want to do I think:
With wsInt
Dim f As Range
Set f = .Cell("Q23")
If IsEmpty(f) Then
MsgBox "The data can't entered, you have not entered any data into the Sales Order field."
Else
c = Array(.Range("B11"), .Range("B14"), .Range("B17"), .Range("B20"), .Range("Q23"), .Range("B23") _
, .Range("Q11"), .Range("Q14"), .Range("Q17"), .Range("Q20"), .Range("R26"), .Range("V23") _
, .Range("V25"), .Range("V27"), .Range("B32"), .Range("B40"), .Range("B46"), .Range("B52") _
, .Range("D58"), .Range("L58"), .Range("V58"))
End If
End With
Maybe as simple as:
With wsInt
If Len(.Range("Q23")) = 0 Then
MsgBox "The data can't be entered, you have not entered any data into the Sales Order field."
Exit Sub
End If
End With 'added this line for clarity
Related
I have two ranges, [H23:I32] and [J23:K50].
I need to copy values from [H23:I32] to [J23:K50] if [J23:K50] is empty, and if [J23:K50] is not empty I need to find the last row and add [H23:I32] below.
The "copy if empty" works, but the "add to the end of the list" doesn't unfortunately.
It does something, but clearly not the thing I need.
Sub Total_Loop()
Application.ScreenUpdating = False
Dim c As Range
For Each c In Range("J23:K50" & Cells(Rows.Count, "J").End(xlUp).Row)
If c.Value <> "" Then
Range("J23:K50" & Cells(Rows.Count, "J").End(xlUp).Row + 1) = Range("H23:I32")
Else: c.Value = c.Offset(, -2).Value
End If
Next
Application.ScreenUpdating = True
End Sub
Any suggestions how to fix this?
EDIT: After a lot of struggle I found a suitable solution!
Sub MoveData()
Dim lrow As Long
Dim ws As Worksheet
Set ws = Sheets("Loot")
If WorksheetFunction.CountA(ws.Range("J23:K50")) = 0 Then
ws.Range("H23:I32").Copy
ws.Range("J23").PasteSpecial xlPasteValues
Else
lrow = ws.Range("J23:K50").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ws.Range("H23:I32").Copy
ws.Range("J" & lrow + 1).PasteSpecial xlPasteValues
End If
End Sub
I want the values in Column D to change depending upon the value in Column A. Some values do not need to be amended at all if the conditions aren't met
Sub Test()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim row As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
I think I have an error in the lines beginning with c.Value = c.Value * .....
I'm new to VBA and just trying to make sense of it
I just provide this variant. It is working with array, so theoretically it is very quick. Probably no need to turn off the screen updating.
Sub test()
Dim lastRow As Long, i As Long
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
Dim vA As Variant 'Represents A2-A lastrow
vA = .Range("A2").Resize(lastRow - 1).Value
Dim vb As Variant 'Represents D2-D lastrow
vb = .Range("D2").Resize(lastRow - 1).Value
i = 0
Dim v As Variant
For Each v In vA
i = i + 1
If v = "Bol" Then
vb(i, 1) = vb(i, 1) * 1.19
ElseIf v = "Amazon" Then
vb(i, 1) = vb(i, 1) * 1.2
End If
Next v
.Range("D2").Resize(lastRow - 1).Value = vb ' Writing the values to the D column
End With
End Sub
You have to forecast and handle all possible conditions. Use this code please:
Sub Test()
Application.ScreenUpdating = False
Dim row As Integer
Dim Lastrow As Long
'I've assumed that you are working on sheet1
Lastrow = Sheets(1).Cells(Rows.Count, "D").End(xlUp).row
If Lastrow > 1 Then
For row = 2 To Lastrow
If Sheets(1).Cells(row, 1).Value = "Bol" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.19
End If
If Sheets(1).Cells(row, 1).Value = "Amazon" Then
Sheets(1).Cells(row, 4).Value = Sheets(1).Cells(row, 4).Value * 1.2
End If
Next
Else
MsgBox ("There is no data at column D")
End If
Application.ScreenUpdating = True
End Sub
There are quite a few ways to go about what you're trying to do. For what it's worth, this is how I would go about it. You had a few additional variables you didn't need, and your 'row' variable wasn't assigned a value at all.
Sub test2()
Dim lastRow As Long, _
i As Long
Application.ScreenUpdating = False
With Sheet1
lastRow = .Cells(Rows.Count, "D").End(xlUp).row
For i = 2 To lastRow
If .Cells(i, 1).Value = "Bol" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.19
End If
If .Cells(i, 1).Value = "Amazon" Then
.Cells(i, 4).Value = .Cells(i, 4).Value * 1.2
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I kept is relatively simple, so hopefully you can follow what's going on. If you have a lot of "If" statements, it may be cleaner to use VBAs "Select Case".
Also the text strings as you have them set up are case sensitive. "Bol" does not equal "bol" maybe that doesn't matter, but something to be aware of. If the string you pass it is "amazon" it will not pass the 'If' test.
Another assumption I made was that your data is on Sheet1. You should get in the habit of fully qualifying your ranges, it will make your life a lot easier as your code gets more complicated.
Last bit, I'm assuming the values in column D are all numbers. If there is text in there, you may run in to problems multiplying it.
Good luck!
You can simplify your code, and make it easier to read, by looping trough column A instead of column D and using the If/ElseIf statement to test each cell for either of the two conditions. By setting your range and defining c as a range variable for each cell in the range, you only have to loop through each cell and test for the two conditions. If the cell contains Bol use the Offset property to multiple the current value in column D by 1.19; ElseIf the cell contains Amazon use the Offset property to multiple the current value in column D by 1.2. Comments provide in the code.
Application.ScreenUpdating = False
'use the With statement to define your workbook and sheet, change as needed
'Note: "ThisWorkbook" identifies the workbook which contains this code
With ThisWorkbook.Sheets("Sheet1")
'Define the range you want to loop through, using the column you want to test
Dim rng As Range: Set rng = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
'Define the variable for each cell-range
Dim c As Range
'loop through each "c" in the range and if one of the conditions are met
For Each c In rng
If c = "Bol" Then
'then use the "Offset property" to modify the value in column D
c.Offset(, 3) = c.Offset(, 3).Value * 1.19
ElseIf c = "Amazon" Then
c.Offset(, 3) = c.Offset(, 3).Value * 1.2
End If
Next c
End With
Application.ScreenUpdating = True
In-Place Modification
All the solutions have one common issue: you can use them only once. If you need to change the values after adding new records (rows) you should consider adding another column with the initial values so the code could be written to identify what has already been changed and what not. But that's for another question.
Your Sub Solution
You actually had only one serious mistake in two-three places.
Instead of row in the If statements you should have used c.Row and you could have removed Dim row As Integer:
Sub Test_Almost_Fixed()
Application.ScreenUpdating = False
Dim startrow As Integer
Dim c As Range
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
Additionally after getting rid of the extra Application.ScreenUpdating = False and the Dim startrow As Integer and some further cosmetics, you could have had something like this:
Sub Test_Fixed()
Dim c As Range
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).row
Application.ScreenUpdating = False
For Each c In Range("D2:D" & Lastrow)
If Cells(c.Row, 1) = "Bol" Then
c.Value = c.Value * 1.19
End If
If Cells(c.Row, 1) = "Amazon" Then
c.Value = c.Value * 1.2
End If
Next
Application.ScreenUpdating = True
End Sub
A More Complex Sub Solution
Use the following for the ActiveSheet in a standard module (e.g. Module1). For a particular sheet you can place it in a sheet module (e.g. Sheet1) or create a button on the sheet.
Tip: When you have such a simple (short, fast) code and especially when you're using a Button to run it (in a 'one-time operation code'), it is good practice to use a MsgBox at the end of the code to actually know that the code has run and to prevent accidentally pressing the Button more than once.
Option Explicit
Sub Test()
Const Proc As String = "Test"
On Error GoTo cleanError
' Define Constants.
Const FirstRow As Long = 2
Const SourceColumn As Variant = 1 ' e.g. 1 or "A"
Const TargetColumn As Variant = 4 ' e.g. 4 or "D"
Dim Criteria As Variant ' Add more values.
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant ' Add more values.
Multiplier = Array(1.19, 1.2)
' Check if Criteria and Multiplier Arrays have the same number
' of elements (columns).
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
' Write Source and Target Ranges to Source and Target Arrays.
Dim rng As Range
' Define Last Non-Empty Cell.
Set rng = Columns(TargetColumn).Find("*", , xlValues, , , xlPrevious)
' Check if Target Column is empty.
If rng Is Nothing Then Exit Sub
' Check if the row of Last Non-Empty Cell is above FirstRow.
If rng.Row < FirstRow Then Exit Sub
Dim Target As Variant
' Write Target Range to Target Array.
Target = Range(Cells(FirstRow, TargetColumn), rng).Value
Set rng = Nothing
Dim ubST As Long: ubST = UBound(Target)
Dim Source As Variant
' Write Source Range to Source Array.
Source = Cells(FirstRow, SourceColumn).Resize(ubST).Value
' Modify Target Array.
Dim i As Long, j As Long
' Loop through elements (rows) of Source and Target Arrays.
For i = 1 To ubST
' Loop through elements (columns) of Criteria and Multiplier Arrays.
For j = 0 To ubCM
' Check if the value in current element (row) of Source Array
' matches the value of current element (column) in Criteria Array.
If Source(i, 1) = Criteria(j) Then
' Modify value in current element (row) of Target Array
' by multiplying it with the value of current element (column)
' of Multiplier Array.
Target(i, 1) = Target(i, 1) * Multiplier(j)
' Since a match is found, there is no need to loop anymore.
Exit For
End If
Next j
Next i
Erase Source
' Write values of Target Array to Target Range.
Cells(FirstRow, TargetColumn).Resize(ubST).Value = Target
Erase Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
End Sub
An Event Solution
To make it automatically change the values in column D for each change of a value in column A you can place the following code into the sheet module (e.g. Sheet1):
Option Explicit
Private Const SOURCE_COLUMN As Variant = 1 ' e.g. 1 or "A"
Private Const TARGET_COLUMN As Variant = 4 ' e.g. 4 or "D"
Private Sub sdfWorksheet_Change(ByVal Target As Range)
Const Proc As String = "Worksheet_Change"
On Error GoTo cleanError
If Intersect(Columns(SOURCE_COLUMN), Target) Is Nothing Then Exit Sub
Const FirstRow As Long = 2
Dim rng As Range
Set rng = Columns(TARGET_COLUMN).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Cells(FirstRow, SOURCE_COLUMN).Resize(rng.row - FirstRow + 1)
If Intersect(rng, Target) Is Nothing Then Exit Sub
Dim cel As Range
Application.Calculation = xlCalculationManual ' -4135
For Each cel In Target.Cells
TestChange cel
Next cel
CleanExit:
Application.Calculation = xlCalculationAutomatic ' -4105
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
Private Sub TestChange(SourceCell As Range)
Const Proc As String = "TestChange"
On Error GoTo cleanError
Dim Criteria As Variant
Criteria = Array("Bol", "Amazon")
Dim Multiplier As Variant
Multiplier = Array(1.19, 1.2)
Dim ubCM As Long: ubCM = UBound(Criteria)
If UBound(Multiplier) <> ubCM Then Exit Sub
Application.ScreenUpdating = False
Dim TargetCell As Range, j As Long
For j = 0 To ubCM
If SourceCell.Value = Criteria(j) Then
Set TargetCell = Cells(SourceCell.row, TARGET_COLUMN)
TargetCell.Value = TargetCell.Value * Multiplier(j)
Exit For
End If
Next j
CleanExit:
Application.ScreenUpdating = True
Exit Sub
cleanError:
MsgBox "An unexpected error occurred in '" & Proc & "'." & vbCr _
& "Run-time error '" & Err.Number & "':" & vbCr & Err.Description _
, vbCritical, Proc & " Error"
On Error GoTo 0
Resume CleanExit
End Sub
I have one Excel sheet with 6000 rows. I need to delete entire rows if distinct values are less than, say, three in one particular column.
Per below example:
In column-A with the list of colours and in column-B with names.
If I filter any 'name in column-B and in column-A, if less than three distinct values = true then entire row should be deleted.
Rows with name- Chary should be deleted.
A B
Color Employee
Red Dev
blue Dev
blue Dev
Red Dev
black Dev
Red Dev
Red Chary
blue Chary
blue Chary
Red Chary
Red Chary
Red Chary
With my code:
First I filter name in column-B then paste the filtered data new workbook and there I will remove duplicates from column-A then will get the unique count.
If the unique count is less than 3 then activate the main sheet and will delete filtered rows and loop to next name.
Sub Del_lessthan_5folois()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
t = Now()
Set wb = ActiveWorkbook
Sheets("VALID ARNS").Activate
iCol = 2 '### criteria column
Set ws = Sheets("VALID ARNS")
Sheets("VALID ARNS").Activate
Set rnglast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUnique = Range(Cells(2, iCol), rnglast).SpecialCells(xlCellTypeVisible)
Workbooks.Add
Set newb = ActiveWorkbook
For Each strItem In rngUnique
If strItem <> "" Then
ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
newb.Activate
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
Application.CutCopyMode = False
Cells.EntireColumn.AutoFit
Dim uniq As Range
Set uniq = Range("A1:S" & Range("A" & Rows.Count).End(xlUp).Row)
uniq.RemoveDuplicates Columns:=7, Header:=xlYes
LastRow = ActiveSheet.UsedRange.Rows.Count
Cells.Delete Shift:=xlUp
Range("A1").Select
wb.Activate
If LastRow < "3" Then
ActiveSheet.AutoFilter.Range.Offset(1,0).Rows.SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
End If
End If
Next
ws.ShowAllData
MsgBox "The entire process took! " & Format(Now() - t, "hh:mm:ss") & " Minutes"
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
My code works in step by step debug mode but when run it skips a lot of rows.
Can this be related to more than 6000 rows?
How do I get the count of distinct values in Column-A when filtered in Column-B?
It's not exactly the same code that you posted as I had some troubles with it, but here's an alternative solution. I simply copy the data into another sheet (please add sheet called "Results" before you run my code), add two more columns with formulas (these will check if a given "Employee" should be deleted), filter on "TRUE" and then delete relevant rows.
From what I tested such solution seems to be faster than applying Advanced Filters, checking for unique values and then looping through the whole dataset. I hope it will work fine for your setup.
Here's the code:
Sub DeleteRows()
Dim t As Variant
Dim iCol As Long, lngLastRow As Long
Dim wsOrig As Worksheet, wsNew As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
t = Now()
Set wsOrig = Sheets("VALID ARNS")
Set wsNew = Sheets("Results")
iCol = 2 '### criteria column
With wsOrig
lngLastRow = .Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious).Row
'copy into Results sheet
.Range("A1:B" & lngLastRow).Copy wsNew.Range("A1")
With wsNew
'add formulas
.Range("C1:D1").Value = VBA.Array("Instance", "Delete?")
.Range("C2:C" & lngLastRow).Formula = "=COUNTIFS($A$2:A2,A2,$B$2:B2,B2)"
.Range("D2:D" & lngLastRow).Formula = "=SUMIFS($C$2:$C$" & lngLastRow & ",$B$2:$B$" & lngLastRow & ",B2,$C$2:$C$" & lngLastRow & ",1)<3"
'delete when column D = TRUE
.Range("A1:D" & lngLastRow).AutoFilter Field:=4, Criteria1:="TRUE"
.Range("D2:D" & lngLastRow).SpecialCells(xlCellTypeVisible).Rows.Delete
'clear
.Range("A1:B" & lngLastRow).AutoFilter
.Range("C:D").Clear
End With
End With
MsgBox "The entire process took! " & Format(Now() - t, "hh:mm:ss") & " Minutes"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
"VALID ARNS" sheet:
"Results" sheet (after running the code):
Edit:
Another option, using Scripting.Dictionary functionality:
Public Function getUnique(ByVal rngVals As Excel.Range) As Variant()
Dim objDictionary As Object
Dim rngRow As Excel.Range
Dim rngCell As Excel.Range
Dim strKey As String
Set objDictionary = CreateObject("Scripting.Dictionary")
For Each rngRow In rngVals.Rows
For Each rngCell In rngRow.Cells
strKey = strKey & "||" & rngCell.Text
Next rngCell
With objDictionary
If Not .Exists(Key:=Mid$(strKey, 3)) Then
Call .Add(Key:=Mid$(strKey, 3), Item:=Mid$(strKey, 3))
End If
End With
strKey = ""
Next rngRow
getUnique = objDictionary.Keys
Set rngVals = Nothing
Set rngRow = Nothing
Set rngCell = Nothing
End Function
Public Sub CountUnique()
Dim rngVals As Excel.Range
Dim varUnique() As Variant
Dim rngCell As Excel.Range
Dim varTemp As Variant
Set rngVals = Sheet3.Range("A2:B13").SpecialCells(12)
varUnique = getUnique(rngVals)
For Each rngCell In rngVals.Columns(2).Cells
varTemp = Filter(varUnique, rngCell.Text, True)
Debug.Print rngCell.Text, UBound(varTemp) - LBound(varTemp) + 1
Erase varTemp
Next rngCell
Set rngVals = Nothing
Set rngCell = Nothing
Erase varUnique
End Sub
I need to have this code look from the bottom up and once it reaches a cell in Column G that is populated it stops deleting lines. Can some one help me out. There will be blanks in column G but, I just need it to look from the bottom up to the last populated cell in column G and delete everything below that.
Routine to Delete Blank Lines to the Datasheet, Uncertainty and Repeatability Sheets
Public Sub DeleteBlankLines()
' Declaring the variables
Dim WS As Worksheet
Dim UncWs As Worksheet, RepWs As Worksheet, ImpWs As Worksheet
Dim StopAtData As Boolean
Dim UserAnswer As Variant
Dim rngDelete As Range, UncDelete As Range, RepDelete As Range, ImpDelete As Range
Dim RowDeleteCount As Integer
'Set Worksheets
Set UncWs = ThisWorkbook.Sheets("Uncertainty")
Set RepWs = ThisWorkbook.Sheets("Repeatability")
Set WS = ThisWorkbook.Sheets("Datasheet")
Set ImpWs = ThisWorkbook.Sheets("Import Map")
'Set Delete Variables to Nothing
Set rngDelete = Nothing
Set UncDelete = Nothing
Set RepDelete = Nothing
Set ImpDelete = Nothing
RowDeleteCount = 0
'Determine which cells to delete
UserAnswer = MsgBox("Do you want to delete empty rows " & _
"outside of your data?" & vbNewLine, vbYesNoCancel)
If UserAnswer = vbYes Then
StopAtData = True
'Not needed Turn off at Call in Form
'Application.Calculation = xlCalculationManual
'Application.ScreenUpdating = False
'Application.EnableEvents = False
' Set Range
DS_LastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
For CurrentRow = DS_StartRow To DS_LastRow Step 1
' Delete blank rows by checking the value of cell in column G (Nominal Value)
With WS.Range("G" & CurrentRow & ":O" & CurrentRow)
If WorksheetFunction.CountBlank(.Cells) >= 9 Then
If rngDelete Is Nothing Then
Set rngDelete = WS.Rows(CurrentRow)
Set UncDelete = UncWs.Rows(CurrentRow)
Set RepDelete = RepWs.Rows(CurrentRow)
Set ImpDelete = ImpWs.Rows(CurrentRow)
RowDeleteCount = 1
Else
Set rngDelete = Union(rngDelete, WS.Rows(CurrentRow))
Set UncDelete = Union(UncDelete, UncWs.Rows(CurrentRow))
Set RepDelete = Union(RepDelete, RepWs.Rows(CurrentRow))
Set ImpDelete = Union(ImpDelete, ImpWs.Rows(CurrentRow))
RowDeleteCount = RowDeleteCount + 1
End If
End If
End With
Next CurrentRow
Else
Exit Sub
End If
'Refresh UsedRange (if necessary)
If RowDeleteCount > 0 Then
UserAnswer = MsgBox("This will Delete " & RowDeleteCount & " rows, Do you want to delete empty rows?" & vbNewLine, vbYesNoCancel)
If UserAnswer = vbYes Then
' Delete blank rows
If Not rngDelete Is Nothing Then
UncWs.Unprotect ("$1mco")
RepWs.Unprotect ("$1mco")
rngDelete.EntireRow.Delete Shift:=xlUp
UncDelete.EntireRow.Delete Shift:=xlUp
RepDelete.EntireRow.Delete Shift:=xlUp
ImpDelete.EntireRow.Delete Shift:=xlUp
UncWs.Protect "$1mco", , , , , True, True
RepWs.Protect ("$1mco")
End If
Else
MsgBox "No Rows will be Deleted.", vbInformation, "No Rows Deleted"
End If
Else
MsgBox "No blank rows were found!", vbInformation, "No Blanks Found"
End If
' Set New Last Row Moved to Event
DS_LastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row
'Update Line Count on Datasheet
WS.Range("A9").Value = DS_LastRow - DS_StartRow + 1
'Not needed Turn on at Call in Form
'Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
'Application.EnableEvents = True
End Sub
Delete Below Last Row
Instead of Delete you can use Clear, or if you want to preserve the formatting below the last row, you can use ClearContents.
The Code
Option Explicit
Sub DelRows()
Const cSheet As Variant = "Sheet1" ' Worksheet Name/Index
Const cColumn As Variant = "G" ' Cirteria Column Letter/Number
Dim lastR As Long ' Last Row
With ThisWorkbook.Worksheets(cSheet)
lastR = .Cells(.Rows.Count, cColumn).End(xlUp).Row
.Range(.Cells(lastR + 1, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete
End With
End Sub
I'm trying to split 700,000 rows into about 27 different tabs, based on manager name. This is obviously a large amount of data and excel runs out of memory and only manages to put across about 100 lines into 1 tab
Does anyone have any idea on how to make the code below more efficient or a different way of getting around running out of memory
Maybe sorting the data first and then cutting and pasting into their own tabs? I'm not sure
Current code:
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Long
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 19
Set ws = Sheets("FCW")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:T1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
Wow. Lots and lots of comments here. #OP, did you ever get this working? If you are still looking for a solution, try this.
Sub Copy_To_Worksheets()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim FieldNum As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim ws2 As Worksheet
Dim Lrow As Long
Dim cell As Range
Dim CCount As Long
Dim WSNew As Worksheet
Dim ErrNum As Long
'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:D" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
'This example filters on the first column in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add
With ws2
'first we copy the Unique data from the filter field to ws2
My_Range.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True
'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A1:A" & Lrow)
'Filter the range
My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _
Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")
'Check if there are no more then 8192 areas(limit of areas)
CCount = 0
On Error Resume Next
CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _
.Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : " & cell.Value _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Split in worksheets"
Else
'Add a new worksheet
Set WSNew = Worksheets.Add(After:=Sheets(Sheets.Count))
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
ErrNum = ErrNum + 1
WSNew.Name = "Error_" & Format(ErrNum, "0000")
Err.Clear
End If
On Error GoTo 0
'Copy the visible data to the new worksheet
My_Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
End If
'Show all data in the range
My_Range.AutoFilter Field:=FieldNum
Next cell
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0
End With
'Turn off AutoFilter
My_Range.Parent.AutoFilterMode = False
If ErrNum > 0 Then
MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _
& vbNewLine & "There are characters in the name that are not allowed" _
& vbNewLine & "in a sheet name or the worksheet already exist."
End If
'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
I just tested the functionality by putting =randbetween(1,27) from A1:A700000. The script did everything in less than 30 seconds on my very old ThinkPad with 12GB RAM.
Edit2:
Added a loop over manager names stored in a string.
i. In general, turning off screen updating in Excel can speed things up.
On Error Goto skpError
Application.ScreenUpdating = False
' your code....
skpError:
Application.ScreenUpdating = True
ii. If you consider a major overhaul, the following could provide a starting point.
I used simplified sample data like this
manager revenue
Henry 500
Henry 500
Willy 500
Willy 500
Billy 500
Billy 500
In short, it does the following:
it reads your data into a recordset
it filters the recordset based on the manager-name
it copies the records from the recordset to the sheet with the manager-name
since it doens't explicitly loop every row, it should perform considerably faster than what you had so far
Hope that helps!
Sub WorkWithRecordset()
Dim ws As Worksheet
Dim iCols As Integer
' 1. Reading all the data into a recordset
Dim xlXML As Object
Dim rst As Object
Set rst = CreateObject("ADODB.Recordset")
Set xlXML = CreateObject("MSXML2.DOMDocument")
xlXML.LoadXML ThisWorkbook.Sheets("Data").UsedRange.Value(xlRangeValueMSPersistXML)
rst.Open xlXML
' 2. manager names - we could also put those into a recordset (similar to above)
' for showing reasons i use an array here
' note: i use 2 Variant variables, so I can loop over the arrays-entries without using LBOUND() to UBOUND()
Dim varManager As Variant
varManager = Split("Billy;Willy;Henry", ";")
' 3. loop over the managers
Dim manager As Variant
For Each manager In varManager
' set the outputsheet
Set ws = ThisWorkbook.Sheets(manager)
' set the filter on managername
rst.Filter = "manager = '" & manager & "'"
With ws
' Print the headers
For iCols = 0 To rst.Fields.Count - 1
.Cells(1, iCols + 1).Value = rst.Fields(iCols).Name
Next
' Print the data
.Range("A2").CopyFromRecordset rst
End With
' delete the filter
rst.Filter = ""
Next manager
' end of manager-loop
Debug.Print "Done. Time " & Now
End Sub
Function GetRecordset(rng As Range) As Object
'Recordset ohne Connection:
'https://usefulgyaan.wordpress.com/2013/07/11/vba-trick-of-the-week-range-to-recordset-without-making-connection/
Dim xlXML As Object
Dim rst As Object
Set rst = CreateObject("ADODB.Recordset")
Set xlXML = CreateObject("MSXML2.DOMDocument")
xlXML.LoadXML rng.Value(xlRangeValueMSPersistXML)
rst.Open xlXML
Set GetRecordset = rst
End Function
Note:
a) the code assumes that there are existing, empty sheets called "Henry", "Billy", "Willy"
b) with 27 sheets you could create manager-sheets dynamically, if they don't already exist
c) i copied the entire rows. if you only need a selection of fields, you could still loop the filtered recordset and access single fields with something like rst!manager
My test stub has 700,000 Rows and 20 Columns of data, 100MB on disk. It takes 6.5 Seconds to parse the data into 27 different worksheets. I'm pretty happy with the results considering it takes 26 Seconds to save the file.
Class Module: ManagerClass
Option Explicit
'Adjust MAXROWS if any Manage will have more than 60000
Private Const MAXROWS As Long = 60000
Private Data
Private m_Manager As String
Private m_ColumnCount As Integer
Private m_Header As Range
Private x As Long
Private y As Integer
Public Sub Init(ColumnCount As Integer, Manager As String, Header As Range)
m_Manager = Manager
m_ColumnCount = ColumnCount
Set m_Header = Header
ReDim Data(1 To MAXROWS, 1 To ColumnCount)
x = 1
End Sub
Public Sub Add(Datum As Variant)
y = y + 1
If y > m_ColumnCount Then
y = 1
x = x + 1
End If
Data(x, y) = Datum
End Sub
Private Sub Class_Terminate()
Dim wsMGR As Worksheet
If Evaluate("=ISREF('" & m_Manager & "'!A1)") Then
Set wsMGR = Worksheets(m_Manager)
wsMGR.Cells.Clear
Else
Set wsMGR = Sheets.Add(after:=Worksheets(Worksheets.Count))
wsMGR.Name = m_Manager
End If
wsMGR.Range(m_Header.Address) = m_Header
wsMGR.Range("A2").Resize(x, m_ColumnCount).Value = Data
End Sub
Standard Module: ParseData
Sub ParseData()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Const MGRCOLUMN As Integer = 19
Const HEADERROW As String = "A1:T1"
Dim Data, MGRData
Dim key As String
Dim MGRClass As ManagerClass
Dim x As Long, y As Long
Dim dicMGR As Object
Set dicMGR = CreateObject("Scripting.Dictionary")
Dim lastRow As Long, z As Long, z2 As Long
With Sheets("FCW")
lastRow = .Cells(.Rows.Count, MGRCOLUMN).End(xlUp).Row
For z = 2 To lastRow Step 10000
z2 = IIf(z + 10000 > lastRow, lastRow, z + 10000)
Data = .Range(Cells(z, 1), .Cells(z2, MGRCOLUMN + 1))
For x = 1 To UBound(Data, 2)
key = Data(x, MGRCOLUMN)
If Not dicMGR.Exists(key) Then
Set MGRClass = New ManagerClass
MGRClass.Init UBound(Data, 2), key, .Range(HEADERROW)
dicMGR.Add key, MGRClass
End If
For y = 1 To UBound(Data, 2)
dicMGR(key).Add Data(x, y)
Next
Next
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
End Sub