I need help with VBA which will split current sheet Test1 depending values from A rows.
Test1 sheet is in format:
Now i need to split sheet Test1 into two (or more) sheets which will contains all rows which begins with 1.1 and 1.4 (this values will be same rule, but different numbers).
So after run VBA code, it will be created sheet Test1-1 (green region) containing all data which starts with 1.1:
1.1
1.1.1
1.1.2
1.1.3
And second sheet Test1-2 (red region) which starts with 1.4:
1.4
1.4.1
1.4.2
After creation origin Test1 sheet can be removed.
Can you please give me help or guide i don't have any clue/idea to achieve this.
With the below code the output will be:
Two Sheets:
Test1-1
Test1-4
If you want to get this output:
Test1-1
Test1-2
You should:
Sort data based on the first column
Create another variable with initial value 1 and every time that Sheetname change value instead of use Sheetname variable , use the new variable.
Guidlines for:
Sorting:
Option Explicit
Sub Sort()
Dim LR As Long
With ThisWorkbook.Worksheets("Test1")
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
ThisWorkbook.Worksheets("Test1").Sort.SortFields.Clear
ThisWorkbook.Worksheets("Test1").Sort.SortFields.Add2 Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Test1").Sort
.SetRange Range("A2:D" & LR)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
New Variable
From: ActiveWorkbook.Worksheets("Test1-" & SheetName)
To: ActiveWorkbook.Worksheets("Test1-" & NewVariable)
Try:
Option Explicit
Sub test()
Dim LR As Long
Dim LRN As Long
Dim i As Long
Dim SheetName As String
Dim wsTest As Worksheet
Dim wsNew As Worksheet
With ThisWorkbook.Worksheets("Test1")
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = LR To 1 Step -1
With ThisWorkbook.Worksheets("Test1")
SheetName = Mid(.Range("A" & i), InStr(1, .Range("A" & i).Value, ".") + 1, 1)
End With
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets("Test1-" & SheetName)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.Name = "Test1-" & SheetName
End If
With ActiveWorkbook.Worksheets("Test1-" & SheetName)
LRN = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
ThisWorkbook.Worksheets("Test1").Range("A" & i & ":D" & i).Cut ActiveWorkbook.Worksheets("Test1-" & SheetName).Range("A" & LRN + 1)
Next i
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Test1").Delete
Application.DisplayAlerts = True
End Sub
Related
I have a sheet of almost 100000 rows & column A to Q
I have a code that delete entire rows if column Q has blank cells.
I have tried this code on 4000 rows it is running in 3 minutes but when I take 100000 rows it just processing for hours.
I will be very great full if some help/guide me in speeding up this code.
The code is :
Sub DeleteBlank()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lo As ListObject
set lo = sheets("BOM 6061").ListObjects(1)
Sheets("BOM 6061").Activate
lo.AutoFilter.ShowAllData
lo.range.AutoFilter Field:=17, Criteria1:=""
Application.DisplayAlerts = False
Application.Calculation = xlCalculationAutomatic
lo.DataBodyRange.SpecialCells(xlCellsTypeVisible).Delete
Application.DisplayAlerts = True
lo.AutoFilter.ShowAllData
End Sub
Remove Criteria Rows in an Excel Table Efficiently
In a nutshell, if you don't sort the criteria column, deleting the rows may take 'forever'.
The following will do just that, keeping the initial order of the remaining rows.
Option Explicit
Sub DeleteBlankRows()
Const wsName As String = "BOM 6061"
Const tblIndex As Variant = 1
Const CriteriaColumnNumber As Long = 17
Const Criteria As String = ""
' Reference the table.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim tbl As ListObject: Set tbl = ws.ListObjects(tblIndex)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Remove any filters.
If tbl.ShowAutoFilter Then
If tbl.AutoFilter.FilterMode Then tbl.AutoFilter.ShowAllData
Else
tbl.ShowAutoFilter = True
End If
' Add a helper column and write an ascending integer sequence to it.
Dim lc As ListColumn: Set lc = tbl.ListColumns.Add
lc.DataBodyRange.Value = _
ws.Evaluate("ROW(1:" & lc.DataBodyRange.Rows.Count & ")")
' Sort the criteria column ascending.
With tbl.Sort
.SortFields.Clear
.SortFields.Add2 tbl.ListColumns(CriteriaColumnNumber).Range, _
Order:=xlAscending
.Header = xlYes
.Apply
End With
' AutoFilter.
tbl.Range.AutoFilter Field:=CriteriaColumnNumber, Criteria1:=Criteria
' Reference the filtered (visible) range.
Dim svrg As Range
On Error Resume Next
Set svrg = tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Remove the filter.
tbl.AutoFilter.ShowAllData
' Delete the referenced filtered (visible) range.
If Not svrg Is Nothing Then svrg.Delete
' Sort the helper column ascending.
With tbl.Sort
.SortFields.Clear
.SortFields.Add2 lc.Range, Order:=xlAscending
.Header = xlYes
.Apply
.SortFields.Clear
End With
' Delete the helper column.
lc.Delete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
' Inform.
MsgBox "Blanks deleted.", vbInformation
End Sub
I would not use an Autofilter on large data sets as they can take quite a bit of time trying to enumerate the available options before actually filtering the data. The AutoFilter.ShowAllData takes just as much time. For my super simple test dataset, which consisted of 26 columns of 1000000 rows, it took 30+ seconds for each to process.
From what I can tell you are filtering the list to show only the blank items and then deleting the blank rows. Since the filtering is what is causing the delay we could just loop through each row looking at a specific column and if it is blank you can just delete it. Below is an example of how to do this.
**Edit: After testing I found this to be much slower than what you would want. Check out the next example below as it is super fast.
Option Explicit
Sub DeleteBlank()
Application.ScreenUpdating = False
Dim calcType As Integer
Dim rowCount, columnNumToCheck, currow, dataStartRow As Long
Dim WkSht As String
Dim lo As ListObject
WkSht = "BOM 6061" 'The name of the worksheet where the table is located.
columnNumToCheck = 17 'The column number to check for blank cells.
calcType = Application.Calculation
Application.Calculation = xlCalculationManual
Set lo = Sheets(WkSht).ListObjects(1)
rowCount = lo.ListRows.Count
dataStartRow = (lo.DataBodyRange.Row - 1)
For currow = rowCount To 1 Step -1
If Sheets(WkSht).Cells((currow + dataStartRow), columnNumToCheck).Value = "" Then
Call DeleteRows(WkSht, (currow + dataStartRow))
End If
Next currow
Application.Calculation = calcType
Application.ScreenUpdating = True
End Sub
Private Sub DeleteRows(sheetNameIn As String, startRow As Long, Optional optionalEndRow As Long)
If IsNull(optionalEndRow) Or optionalEndRow = 0 Then
optionalEndRow = startRow
End If
Worksheets(sheetNameIn).Range(startRow & ":" & optionalEndRow).Delete Shift:=xlUp
End Sub
If you are able to sort your data where the blank cells are all together you could use the below to perform a single delete function remove them all at once. This deleted 70000 rows in a few seconds.
Sub DeleteBlankWithSort()
'Application.ScreenUpdating = False
Dim columnNumToCheck, tableLastRow, lrow As Long
Dim calcType As Integer
Dim WkSht As String
Dim lo As ListObject
WkSht = "BOM 6061" 'The name of the worksheet where the table is located.
columnNumToCheck = 17 'The column number to check for blank cells.
calcType = Application.Calculation
Application.Calculation = xlCalculationManual
Set lo = Sheets(WkSht).ListObjects(1)
tableLastRow = FindLastRow(WkSht, (columnNumToCheck))
With lo.Sort
.SortFields.Clear
.SortFields.Add _
Key:=Range("Table1[[#All],[q]]"), _
SortOn:=xlSortOnValues, _
Order:=xlDescending, _
DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
lrow = FindLastRow(WkSht, (columnNumToCheck), (tableLastRow))
Call DeleteRows(WkSht, (tableLastRow), (lrow + 1))
Application.Calculation = calcType
Application.ScreenUpdating = True
End Sub
Private Sub DeleteRows(sheetNameIn As String, startRow As Long, Optional optionalEndRow As Long)
If IsNull(optionalEndRow) Or optionalEndRow = 0 Then
optionalEndRow = startRow
End If
Worksheets(sheetNameIn).Range(startRow & ":" & optionalEndRow).Delete Shift:=xlUp
End Sub
Private Function FindLastRow(sheetNameIn As String, columnNum As Long, Optional optionalStartRow As Long) As Long
'finds the last row of the column passed in the sheetname passed in
If IsNull(optionalStartRow) Or optionalStartRow = 0 Then
optionalStartRow = 1048576
End If
FindLastRow = Worksheets(sheetNameIn).Range(Cells(optionalStartRow, columnNum).Address).End(xlUp).Row
End Function
I had an simple example of this from a while ago. Advanced filtering is the fastest way to filter in place or to filter and copy in excel/vba. In advanced filtering you usually have your filters listed out in columns/rows and can have as many as you need, use >"" for filtering out blanks on a column, should take no time at all. In my example it might be different as this was used alongside sheetchange to autofilter if anything was added to the filters.
Sub Advanced_Filtering_ModV2()
Dim rc As Long, crc As Long, trc As Long
Dim wb As Workbook, ws As Worksheet
Set wb = ActiveWorkbook: Set ws = wb.Worksheets("sheet1")
ws.Range("AA1").Value = ws.Range("Q1").Value: ws.Range("AA2").Value = ">"""""
On Error Resume Next
ws.ShowAllData: rc = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A1:V" & rc).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=ws.Range("AA1:AA2")
On Error GoTo 0
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 have a default template and need to populate the value in A column (Material) of the output sheet from column I of the source template. I created a macro which duplicates the number of output row based on number of parts in source template. The issue here is the part number is populated only in the first column and its not looping to the other blank rows.
Source Template
Sample Output sheet
Result:
VBA Code:
Sub Process_File()
Dim Src_File As Workbook
Dim Out_Template As Workbook
Dim Src_Tot_Row, Out_Tot_Row As Integer
Dim REG_CODE
REG_CODE = "C299"
Set Src_File = Workbooks.Open("C:\Users\raja\Desktop\NPI Automation\Sadhan\Source_Data.xlsx") 'Read source file name
Set Out_Template = Workbooks.Open("C:\Users\raja\Desktop\NPI Automation\Sadhan\Plant\AMS.xlsx") 'Read output template file name
'------------------------------------------------------------------- Portion-2
' Workbooks.Open (Sheet1.Range("G7").Value) ' Open source excel file
Src_File.Sheets("Input_sheet").Activate
If Range("I7").Value <> "Part numbers" Then ' Checking correct input file
MsgBox "Select correct source file.!"
End
End If
Range("I8").Select
Selection.End(xlDown).Select
Src_Tot_Row = ActiveCell.Row
'------------------------------------------------------------------- Portion-3
' Workbooks.Open (Sheet1.Range("G9").Value) ' Open output template excel file
Out_Template.Sheets("Plant").Activate 'Find Total Rows in Output Template
Range("B1").Select
Selection.End(xlDown).Select
Out_Tot_Row = ActiveCell.Row
Dim Temp_Row_Calc As Integer
Temp_Row_Calc = Src_Tot_Row - 7
Temp_Row_Calc = (Out_Tot_Row - 2) * Temp_Row_Calc ' Calculate total rows for data duplicate
Range("A2:AJ" & Out_Tot_Row).Copy
Range("A" & Out_Tot_Row + 1 & ":AJ" & Temp_Row_Calc + 2).PasteSpecial xlPasteValues
'------------------------------------------------------------------- Portion-4
Range("A1").EntireColumn.Insert ' Inserting temporary column for sorting back
Range("A1").Value = "1"
Range("A" & Temp_Row_Calc - 1).Select
Temp_Row_Calc = Temp_Row_Calc - 1
Range(Selection, Selection.End(xlUp)).Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=Temp_Row_Calc, Trend:=False
If ActiveSheet.AutoFilterMode = False Then ' Check Filter Mode and apply
ActiveSheet.Range("A1").AutoFilter
End If
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range( _
"C1:C" & Temp_Row_Calc), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Plant").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For I = 2 To Temp_Row_Calc
If Range("C" & I).Value = REG_CODE Then
Src_File.Sheets("Input_Sheet").Activate 'Activate Source Excel
ReDim ary(1 To Src_Tot_Row - 1) ' Copy material numbers
For j = 1 To Src_Tot_Row - 1
ary(j) = Src_File.Sheets("Input_Sheet").Cells(j + 1, 1)
Next j
Range("I8:I" & Src_Tot_Row).Copy 'Copy source part numbers
Out_Template.Sheets("Plant").Activate 'Activate Out Template Excel
Range("B" & I).SpecialCells(xlCellTypeVisible).PasteSpecial (xlPasteValues)
ActiveSheet.AutoFilter.Sort.SortFields.Clear
ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range( _
"A1:A" & Temp_Row_Calc), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Plant").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'filtervalues = """8121-0837"", ""B5L47-67901"", ""B5L47-67903"", "" ="""
ary(Src_Tot_Row - 7) = ""
ActiveSheet.Range("$A$1:$AJ$" & Temp_Row_Calc).AutoFilter Field:=2, Criteria1:=ary, Operator:=xlFilterValues
Dim cl As Range, rng As Range
Set rng = Range("A2:A" & Temp_Row_Calc)
For Each cl In rng
If cl.EntireRow.Hidden = False Then 'Use Hidden property to check if filtered or not
If cl <> "" Then
x = cl
Else
cl.Value = x
End If
End If
Next
Exit For
End If
Next I
If ActiveSheet.AutoFilterMode Then ' Check Filter Mode and apply
ActiveSheet.Range("A1").AutoFilter
End If
Columns(1).EntireColumn.Delete
MsgBox "Completed!"
'-------------------------------------------------------------------
End Sub
Function GetFilenameFromPath(ByVal strPath As String) As String
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function
Sub Test()
Range("A1").Value = "1"
Range("A" & Out_Tot_Row).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=Out_Tot_Row, Trend:=False
End Sub
Your code has several errors, suggest to Step Into it using [F8] and the Locals Window then you will be able to see/learn what each line of the code is doing and apply necessary correction. Besides that, to have your code looping through all rows remove this line Exit For near the end of the Process_File procedure.
It seems that your objective is to duplicate all records in the worksheet Plant times the number of Part Numbers in worksheet Input_sheet, assigning to each record in the worksheet Plant each of the Part Numbers in worksheet Input_sheet. If this is correct then try this code:
Solution:
This code assumes the following:
The Part Numbers are continuous (no blank cells in between)
The Data in worksheet Plant is continuous, starting at A1 and contains a header row.
.
Rem The following two lines must be at the top of the VBA Module
Option Explicit
Option Base 1
Sub Process_File()
Dim wbkSrc As Workbook, wbkTrg As Workbook
Dim wshSrc As Worksheet, wshTrg As Worksheet
Dim aPrtNbr As Variant, aData As Variant
Dim lItm As Long, lRow As Long
Rem Application Settings OFF
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Rem Set Source Worksheet
On Error Resume Next
Set wbkSrc = Workbooks.Open("C:\Users\raja\Desktop\NPI Automation\Sadhan\Source_Data.xlsx")
Set wshSrc = wbkSrc.Worksheets("Input_sheet")
If wshSrc Is Nothing Then GoTo ExitTkn
Rem Set Target Worksheet
Set wbkTrg = Workbooks.Open("C:\Users\raja\Desktop\NPI Automation\Sadhan\Plant\AMS.xlsx")
Set wshTrg = wbkTrg.Worksheets("Plant")
If wshTrg Is Nothing Then GoTo ExitTkn
Rem Application Settings OFF
Application.DisplayAlerts = False
With wshSrc.Range("I7")
If .Value2 <> "Part numbers" Then
Rem Validate Input Worksheet
MsgBox "Select correct source file!", vbSystemModal + vbCritical
GoTo ExitTkn
Else
Rem Set Part Number Array
aPrtNbr = .Offset(1).Resize(-.Row + .End(xlDown).Row).Value2
aPrtNbr = WorksheetFunction.Transpose(aPrtNbr)
End If: End With
Rem Set Data Array
With wshTrg.Cells(1).CurrentRegion
aData = .Offset(1).Resize(-1 + .Rows.Count).Value2
End With
Rem Duplicate Data and Assign Part Numbers
With wshTrg
For lItm = 1 To UBound(aPrtNbr)
lRow = lRow + IIf(lItm = 1, 2, UBound(aData))
With .Cells(lRow, 1).Resize(UBound(aData), UBound(aData, 2))
.Value = aData
.Columns(1).Value = aPrtNbr(lItm)
End With: Next: End With
ExitTkn:
Rem Application Settings OFF
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
Option keyword,
On Error Statement,
With Statement,
Using Arrays,
WorksheetFunction Object (Excel),
For...Next Statement,
Range Object (Excel),
Range.CurrentRegion Property (Excel),
Range.Offset Property (Excel)
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
I use two workbooks (obviously based on the question:)), from the first one (as you will see in the code below) gets sorted by the data in column "B". The data in this column is just a number based on the month (11=November, December=12, etc.). For this question (and it will provide the answer for my other monthly workbooks), need to copy all the rows of data (columns A:AE) in column B to another workbook (which is already open), and paste the data into the empty row at the bottom. I have the sort part working fine. I am trying to add in the copy & paste function into the code, but can't get it to work. HELP!
Here is the code I have tried (but can't figure out how to get focus to the target workbook):
Sub Extract_Sort_1512_December()
' This line renames the worksheet to "Extract"
Application.ScreenUpdating = False
ActiveSheet.Name = "Extract"
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:Z2000")
.Apply
End With
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Range("B" & LR).Value <> "12" Then
Rows(LR).EntireRow.Hidden = True
End If
Next LR
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = “12” Then
Range(Cells(i, 1), Cells(i, 31)).Select
Selection.Copy
ActiveWorkbook(“Master File - Swivel - December 2015.xlsm”).Select
Worksheets(“Master”).Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i
Application.ScreenUpdating = True
End Sub
I have found this code below, but do not know how to insert it properly into my code above. The thing that makes me weary is that the workbooks are already open. The target workbook is located on our SharePoint site and I do not know how (or if) you can use VBA code to open it to your desktop.
Here is the other code:
Sub Demo()
Dim wbSource As Workbook
Dim wbTarget As Workbook
' First open both workbooks :
Set wbSource = Workbooks.Open(" ") ' <<< path to source workbook
Set wbTarget = ActiveWorkbook ' Workbooks.Open(" ") ' <<< path to destination workbook
'Now, transfer values from wbSource to wbTarget:
wbTarget.Sheets("Sheet1").Range("B2").Value = wbSource.Sheets("Sheet3").Range("H4")
wbTarget.Sheets("Sheet1").Range("B3").Value = wbSource.Sheets("Sheet3").Range("J10")
'Close source:
wbSource.Close
End Sub
I have modified your code slightly, but kept most of it as is.
I think the problem was related to the way in which you were trying to activate the workbook where the data was to be pasted. Normally the Activate command is used with workbooks, as opposed to Select. However, I bypassed the whole activation of the new workbook, because it would require you to then "re-activate" the original workbook before copying the next line. Otherwise you would be copying from the active workbook, which would now be the one to be pasted into. Please see the code - it should be fairly straightforward.
Sub Extract_Sort_1512_December()
Application.ScreenUpdating = False
' This line renames the worksheet to "Extract"
ActiveSheet.Name = "Extract"
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:Z2000")
.Apply
End With
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Not Range("B" & LR).Value = "12" Then
Rows(LR).EntireRow.Hidden = True
End If
Next LR
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = "12" Then
' As opposed to selecting the cells, I just copy them directly
Range(Cells(i, 1), Cells(i, 31)).Copy
' As opposed to "Activating" the workbook, and selecting the sheet, I just paste the cells directly
With Workbooks("Master File - Swivel - December 2015.xlsm").Sheets("Master")
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(erow, 1).PasteSpecial xlPasteAll
End With
Application.CutCopyMode = False
End If
Next i
Application.ScreenUpdating = True
End Sub