Sort without moving formatting - sorting

I have an Excel table in which multiple rows are given different coloured backgrounds by VBA macros. These background colours should be locked to the rows. My problem is that when the table is sorted by one column or another the background colours move as the data is reordered.
Can I format in another way to stop this happening so that the cells remain locked?
The code I use to format is:
For Each Row In rng.Rows
If Condition Then
Row.Select
cIndex = ColourIndex(colour)
With Selection.Interior
.ColorIndex = cIndex
End With
End If
Next
An example of my table is like this:
EDIT: Extra Code
Sub Quota(ByVal Type As String)
Dim records As Long
Dim sht1 As Worksheet
Set sht1 = Worksheets("Sheet1")
Dim sht2 As Worksheet
Set sht2 = Worksheets("Sheet2")
records = sht1.Range("A1048576").End(xlUp).Row - 5
Dim rng As Range
Dim rngRowCount As Long
Dim rLastCell As Range
Dim i As Long
sht2.Activate
'Last used cell
Set rLastCell = sht2.Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
'All used columns except 1st
Set rng = sht2.Range(Cells(2, 1), rLastCell)
rng.Select
rngRowCount = rng.Rows.CountLarge
For i = 1 To rngRowCount
Dim valueAs String
Dim colour As String
Dim VarX As Long
Dim maxValue As Long
value= sht2.Cells(i + 1, 1).Value
colour = sht2.Cells(i + 1, 2).Value
If Type = "A" Then
VarX = sht2.Cells(i + 1, 3).Value
ElseIf Type = "B" Then
VarX = sht2.Cells(i + 1, 5).Value
End If
maxValue = (records / 100) * VarX
ColourRows value, colour, maxValue
Next i
End Sub
Sub ColourRows(value As String, colour As String, maxValue As Long)
Dim sht1 As Worksheet
Set sht1 = Worksheets("Sheet1")
sht1.Activate
Dim rng As Range
Dim firstSixRowsOnwards As Range
Dim lastColumn As Long
Dim usedColumns As Range
Dim usedColumnsString As String
Dim highlightedColumns As Range
Dim rngDataRowCount As Long
Dim performancevalueAs String
Dim cIndex As Integer
Dim count As Long
count = 0
Dim rLastCell As Range
'End row
rngDataRowCount = sht1.Range("A1048576").End(xlUp).Row
'First 6 rows
Set firstSixRowsOnwards = sht1.Range("A6:XFD1048576")
'Last column
lastColumn = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
'Used Range
Set rng = sht1.Range(Cells(1, 1), Cells(rngDataRowCount, lastColumn))
'Used Columns
Set usedColumns = sht1.Range(Cells(1, 1), Cells(1048576, lastColumn))
Set rng = Intersect(rng, firstSixRowsOnwards, usedColumns)
For Each Row In rng.Rows
compareValue= Cells(Row.Row, 5)).Value
If (InStr(1, value, compareValue, 1) Then
Dim rowNumber As Long
Row.Select
If count < maxValue Then
cIndex = ColourIndex(colour)
With Selection.Interior
.ColorIndex = cIndex
End With
count = count + 1
Else
cIndex = 3 'red
With Selection.Interior
.ColorIndex = cIndex
End With
End If
End If
Next
End Sub

I believe that if you select your data by column and then sort (instead of a row limited range) then formatting will follow.
EDIT:
If you want to lock the formatting then use conditional formatting that is based on row number, e.g. ROW() = x or ROW() = range of values...
Tested: Use conditional formatting by formula set rule such as =ROW()=3 make sure excel does not double quote it for you, apply this to the entire data range. Row 3 will then always be formatted as you set here.
Setting in vba
Sub test()
Range("A3").Select
With Range("A3")
.FormatConditions.Add Type:=xlExpression, Formula1:="=ROW()=3"
.FormatConditions(1).Interior.ColorIndex = 46
End With
End Sub

Can be done with CF, for example (top rule is >11):
Edit - I inadvertently left out one rule
the second down below uses =ROW($A1)=11:

Here we go:
In this case, what I would do it one of the two things:
Conditional formatting. Needs lot of logics and manual steps so let us leave it.
A macro: Whenever you sort the data, please fire the following function
Sub Option1()
Dim row As Range
Dim rowNum As Integer
Dim tRange As Range
'set range here: in your example, it is A2:D11
Set tRange = ActiveSheet.Range("A2:D11")
'clear colors
tRange.ClearFormats ' clears the previous format
rowNum = 1
For Each row In tRange.Rows
Select Case rowNum
Case 1, 2
row.Interior.Color = RGB(255, 255, 0) ' 1 and 2nd will be yellow
Case 3, 4
row.Interior.Color = 255 ' 3rd and 4th row will be red
Case 5, 6
row.Interior.Color = RGB(0, 0, 255) ' 5 and 6th row will be blue
Case Else
row.Interior.Color = RGB(0, 255, 0) '' all the bottom row would be a Green row
End Select
rowNum = rowNum + 1
Next row
End Sub
Does it help?

Related

Transfer data from sub-Sub to Function and back to main Sub

I'm trying to write code that fill array in Function and than return result to main Sub. But this Function called from another Sub (sub-Sub). To understand how this will work I tried go step by step. And wrote this code:
Sub CATMain()
Dim val1
Call WalkDownTree() 'Here I call Sub to walk down Product Tree in CATIA
val1 = ParamTable(PartNumber, Name, Material, Texture, Color, Quantity)
For i=0 To UBound(val1)
MsgBox val1(i)
Next
End Sub
Sub WalkDownTree() 'Simplified code of the walk down tree to understand data transfer
PartNumber = "PartNumber"
Name = "Name"
Material = "Material"
Texture = "Texture"
Color = "Color"
Quantity = 1
Call ParamTable(PartNumber, Name, Material, Texture, Color, Quantity)
End Sub
Function ParamTable(PartNumber, Name, Material, Texture, Color, Quantity) 'Simplified array filing code. At original code I get all data from Part
Dim BOMTable(6,1000)
BOMTable(1,k) = PartNumber
BOMTable(2,k) = Name
BOMTable(3,k) = Material
BOMTable(4,k) = Texture
BOMTable(5,k) = Color
BOMTable(6,k) = 1
ParamTable = BOMTable
End Function
But I have error at line "MsgBox val1(i)": "Subscript out of range".
What did I miss?
And maybe exists more simple way to transfer array from Function to main Sub when Function fill from sub-Sub?
After some time I have a solution
This code works:
Dim PartNumber, Name, Material, Texture, Color, Quantity, k
Dim BOMTable(6,1000)
Sub CATMain()
Dim val1
Call WalkDownTree()
val1 = ParamTable(PartNumber, Name, Material, Texture, Color, Quantity, k)
For i = 1 To UBound(val1, 1)
For j = 1 To k-1
MsgBox val1(i,j)
Next
Next
End Sub
Sub WalkDownTree()
For k = 1 To 3
PartNumber = "PartNumber" & k
Name = "Name" & k
Material = "Material" & k
Texture = "Texture" & k
Color = "Color" & k
Quantity = 1
Call ParamTable(PartNumber, Name, Material, Texture, Color, Quantity, k)
Next
End Sub
Function ParamTable(PartNumber, Name, Material, Texture, Color, Quantity, k)
BOMTable(1,k) = PartNumber
BOMTable(2,k) = Name
BOMTable(3,k) = Material
BOMTable(4,k) = Texture
BOMTable(5,k) = Color
BOMTable(6,k) = Quantity
ParamTable = BOMTable
End Function
I would suggest not to be slacking in declaration of variables and even if it's not necessary for functioning. It is necessary for understanding.
The main global variable which holds all data should be declared on top
Option Explicit
Dim BOMData() As Variant
Then write the CATMain()
Sub CATMain()
Dim ItemCount As Integer 'This would be how many rows i will have in BOM or how many parts i will read i have to get this info from CATIA
ReDim BOMData(0 To ItemCount - 1, 0 To 5) As Variant 'This is making the collection
Dim Row As Integer
Dim Col As Integer
For Row = 0 To ItemCount - 1 'populate the BOM collection
Call WalkDownTree(Row)
Next
Dim TempStr As String
For Row = 0 To ItemCount - 1 'just write each row to msgbox
For Col = 0 To 5
TempStr = TempStr & BOMData(Row, Col) & " "
Next
Call MsgBox(TempStr)
TempStr=""
Next
End Sub
This is how could look the sub which populates the collection ... you are iterating through row or that could be items (products, parts etc)
Sub WalkDownTree(Row As Integer)
BOMData(Row, 0) = "PartNumber"
BOMData(Row, 1) = "Name"
BOMData(Row, 2) = "Material"
BOMData(Row, 3) = "Texture"
BOMData(Row, 4) = "Color"
BOMData(Row, 5) = 1
End Sub
The advantage of this solution could bring you simple excel export like this
Sub WriteToExcel()
Dim ExlApp As Excel.Application
Set ExlApp = GetObject(, "EXCEL.Application")
Dim ExlWorkBook As Workbook
Set ExlWorkBook = ExlApp.Workbooks.Open("C:\Test.xls")
Dim ExlSheet As Worksheet
Set ExlSheet = ExlWorkBook.Worksheets.Item(1)
ExlSheet.Range("A1").Resize((UBound(BOMData, 1) - LBound(BOMData, 1) + 1), (UBound(BOMData, 2) - LBound(BOMData, 2) + 1)).Value = BOMData
End Sub
EDIT
This is VBScript version. However i would suggest using VBA or VB .Net language for Catia if you want to seriously develop something. Using VBScript if not necessary is just torturing yourself
Dim BOMData()
Sub CATMain()
Dim ItemCount
ItemCount = 10 'how many items you have
ReDim BOMData (ItemCount - 1, 5)
Dim Row
Dim Col
For Row = 0 To ItemCount - 1 'populate the BOM collection
Call WalkDownTree(Row)
Next
Dim TempStr
For Row = 0 To ItemCount - 1 'just write each row to msgbox
For Col = 0 To 5
TempStr = TempStr & BOMData(Row, Col) & " "
Next
Call MsgBox(TempStr)
TempStr=""
Next
End Sub
Sub WalkDownTree(Row)
BOMData(Row, 0) = "PartNumber"
BOMData(Row, 1) = "Name"
BOMData(Row, 2) = "Material"
BOMData(Row, 3) = "Texture"
BOMData(Row, 4) = "Color"
BOMData(Row, 5) = 1
End Sub

Optimizing Execution Speed Advanced Filter Loop with Calculation of each record

Problem: Code executes at about 30 seconds per record. Need to optimize speed. Spreadsheet is built around 1 page of 100,000's of records, one record is compared to up-to 100 other records from the list using an advanced filter and lookups. Various adjustments are calculated and then values from calculation are returned back onto the "output page" for about 60,000 records. Issue is 60,000 records*30 seconds=500 hours. Thanks.
Sub EquityAutomated()
Dim i As Long
Dim StartNo As Long
Dim EndNo As Long
StartNo = InputBox("Enter the row on the Hsheet sheet you want the equity analysis to start on")
EndNo = InputBox("Enter the row on the Hsheet sheet you want the equity analysis to end on")
Dim wsProtestTest As Worksheet: Set wsProtestTest = Worksheets("ProtestTestData")
Dim wsES As Worksheet: Set wsES = Worksheets("EquitySpreadsheet")
Dim wsEL As Worksheet: Set wsEL = Worksheets("EquityList")
Dim wsDa As Worksheet: Set wsDa = Worksheets("Res")
Dim subTotalsDa As Range: Set subTotalsDa = wsDa.Range("A10:A647649")
Dim fltrRng As Range: Set fltrRng = wsDa.Range("A9:T647649")
Dim fltrCritRng As Range: Set fltrCritRng = wsDa.Range("A1:T2")
Dim valRngDa As Range: Set valRngDa = wsDa.Range("T10:T647649")
Dim fullSrtRng As Range: Set fullSrtRng = wsDa.Range("A9:S647649")
Dim sortValRng As Range: Set sortValRng = wsDa.Range("T9")
Dim fullSortRngVal As Range: Set fullSortRngVal = wsDa.Range("A10:T647649")
Dim equityRankRng As Range: Set equityRankRng = wsEL.Range("P5")
Dim equityOutOfRng As Range: Set equityOutOfRng = wsEL.Range("P4")
Dim MedianRng As Range: Set MedianRng = wsEL.Range("O6")
Dim propValRng As Range: Set propValRng = wsEL.Range("D5")
Dim diffRng As Range: Set diffRng = wsEL.Range("O7")
Dim MinRng As Range: Set MinRng = wsEL.Range("O8")
Dim MaxRng As Range: Set MaxRng = wsEL.Range("O9")
Dim avgRng As Range: Set avgRng = wsEL.Range("O10")
Dim LogRng As Range: Set LogRng = wsES.Range("B10")
Dim Support3kLowerRng As Range: Set Support3kLowerRng = wsEL.Range("O11")
Application.ScreenUpdating = False
For i = StartNo To EndNo
LogRng = wsProtestTest.Cells(i + 2, 1).Value2
subTotalsDa.ClearContents
Application.Calculate
If Not Application.CalculationState = xlDone Then
DoEvents
End If
Application.Calculation = xlManual
fltrRng.AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=fltrCritRng, Unique:=False
Application.Calculation = xlCalculationAutomatic
Application.Calculate
subTotalsDa.SpecialCells(xlCellTypeVisible).FormulaR1C1 = _
"=Subtotal(3,R10C2:RC[1])"
valRngDa.SpecialCells(xlCellTypeVisible).Formula = _
"=INDEX(EquitySpreadsheet!$C$12:$GT$29,16,(MATCH(INDIRECT(ADDRESS(ROW(),1)),EquitySpreadsheet!$C$12:$GS$12)+1))"
With wsDa.Sort
.SortFields.Clear
.SortFields.Add Key:=valRngDa, SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange fullSortRngVal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
With wsProtestTest
.Cells(i + 2, 29) = equityRankRng: .Cells(i + 2, 30) = equityOutOfRng: .Cells(i + 2, 31) = Support3kLowerRng
.Cells(i + 2, 32) = MedianRng: .Cells(i + 2, 33) = propValRng
.Cells(i + 2, 34) = diffRng: .Cells(i + 2, 35) = MinRng
.Cells(i + 2, 36) = MaxRng: .Cells(i + 2, 37) = avgRng
End With
Next
Application.ScreenUpdating = True
End Sub
Edit:
Effectively what happens:
1. Log is used to pull criteria for advanced filter.
2. Adjusted value column is cleared (subtotals) to allow to be repopulated later after calc
3. Advanced filter is ran using criteria from earlier
4. After filter is ran the data in the returned cells are pulled into a sheet (subtotal is used to produce an identified for the index/match 1,2,3, etc. for each returned record). Index/match is used to populate various items of adjustment and then basic formulas are used to determine proper adjustment to subject(square footage, etc.)
5. Various amounts are summed on the calc sheet to return an "indicated value." This then populates the "valRng" using the index match you see in the macro.
6. The filtered data is sorted low to high based on valRng.
7. Values are brought onto the summary sheet for archiving, since the rest of the workbook updates with each new record. (With wsProtestTest section).
It is not possible for me to understand your overall calculation process, but several things stand out as needing to be changed:
Rather handling cells in a range one at a time (for example C6:C11) use a variant array
Run the whole loop in Manual calculation mode and use application.Calculate as infrequently as possible.
Find an alternative way of achieving your desired results that does not involve sorting and filtering 650000 rows 60000 times!
INDIRECT is a volatile function and will slow down calculation: find a different way of doing the calculation that does not involve INDIRECT

Compare value in 2 excel sheet and sort by descending in VBA

I'd like to use excel 2010 to realize a function to first compare values from 2 different Excel sheets and then sort them based on another column value.
For example:
In sheet 1, I've got:
Name Value
Test 1 100.5
Test 1 200.6
Test 1 300.3
Test 2 100.8
Test 2 200.6
Test 3 200.5
In sheet 2, I've got :
Name
Test 1
Test 1
Test 1
Test 3
what I want to achieve is if the name from sheet 1 is not in sheet 2, delete the whole line in sheet 1 and sort by descending the name based on the column value.
Desired:
Name Value
Test 1 300.3
Test 1 200.6
Test 1 100.5
Test 3 200.5
Here is what I get so far:
Sub test()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Integer, j As Integer
Dim lastRow1 As Integer, lastRow2 As Integer
On Error GoTo 0
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
lastRow1 = ws1.UsedRange.Rows.Count
lastRow2 = ws2.UsedRange.Rows.Count
For i = 2 To lastRow1
For j = 2 To lastRow2
If ws1.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If InStr(1, ws2.Cells(j, 1).Value, ws1.Cells(i, 1).Value, vbTextCompare) < 1 Then
Rows(i).EntireRow.delete
Exit For
End If
End If
Next j
Next i
End Sub
Please suggest and help. thank you very much in advance.
I changed your code so it is working:
Sub test()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Integer, j As Integer
Dim lastRow1 As Integer, lastRow2 As Integer
On Error GoTo 0
Set wb = ActiveWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row 'last used cell in column A
lastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row 'last used cell in column A
Dim same As Boolean
same = False
For i = lastRow1 To 2 Step -1 'bottom to top
For j = 2 To lastRow2
Debug.Print ws1.Cells(i, 1).Value
Debug.Print ws2.Cells(j, 1).Value
If ws1.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value Then
same = True 'set True if match
End If
End If
Next j
If same = False Then 'if no match
Rows(i).EntireRow.Delete
End If
same = False
Next i
'sort
lastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & lastRow1).Sort key1:=Range("A2:A" & lastRow1), order1:=xlAscending, Header:=xlNo, key2:=Range("B2:B" & lastRow1), order2:=xlAscending, Header:=xlNo
End Sub
Still thinking about the rest of the answer, but in advance I would advise you to start at the bottom of the list (so from lastrow to the second row) The reason for this is that you are removing rows which your counter does not take into account. You may also want to look into the MATCH function in Excel to see if a certain value is used in a list instead of going through the whole list.

Excel Sort By Numbers Macro

I use a macro to delete rows which doesnt containing numbers for my report.
This macro find critical path numbers and split them. In a1 column it delete the numbers which doesnt in the list.
This macro works fine. Beside that i want to sort a1 column by critical path number orders.
In this link I added what i want and my report file. There is a critical path text at the bottom in report file. When i click Düzenle macro delete rows but not sort by critical path number orders.
Thanks for your helps!
I do not like performing complex changes and deleting rows at the same time. If anything goes wrong, you have to restore the worksheet. I have introduced a new worksheet "Critical Path" and have copied to it everything required from worksheet "Revit KBK Sonuç" in the desired sequence.
I have described what I am doing and why within the macro. I hope it is all clear but ask if necessary.
Option Explicit
Sub ertert()
' I avoid literals within the code if I think those literals may change
' over time and/or if I think a name would make the code clearer.
Const ColLast As Long = 10
Const ColShtHdrLast As Long = 2
Const TableHdr1 As String = "Total Pressure Loss Calculations by Sections"
Dim ColCrnt As Long
Dim Section() As String
Dim CriticalPath As String
Dim InxSect As Long
Dim Rng As Range
Dim RowDestNext As Long
Dim RowSrcLast As Long
Dim RowTableHdr1 As Long
Dim wshtDest As Worksheet
Dim wshtSrc As Worksheet
Set wshtSrc = Worksheets("Revit KBK Sonuç")
Set wshtDest = Worksheets("Critical Path")
With wshtDest
.Cells.EntireRow.Delete
End With
' I only work on the ActiveWorksheet if the user is to select the
' target worksheet in this way. Code is easier to understand if
' With statements are used.
With wshtSrc
' Copy column widths
For ColCrnt = 1 To ColLast
wshtDest.Columns(ColCrnt).ColumnWidth = .Columns(ColCrnt).ColumnWidth
Next
' I avoid stringing commands together. The resultant code may be
' marginally faster but it takes longer to write and much longer
' to decipher when you return to the macro in 12 months.
' Extract critial path string and convert to array of Section numbers
RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
CriticalPath = .Cells(RowSrcLast, "A").Value
' Extract text before trailing total pressure loss
CriticalPath = Split(CriticalPath, ";")(0)
' Discard introductory text and trim spaces
CriticalPath = Trim(Split(CriticalPath, ":")(1))
Section = Split(CriticalPath, "-")
Set Rng = .Cells.Find(What:=TableHdr1)
If Rng Is Nothing Then
Call MsgBox("I am unable to find the row containing """ & _
TableHdr1 & """", vbOKOnly)
Exit Sub
End If
RowTableHdr1 = Rng.Row
' Copy header section of worksheet without buttons
.Range(.Cells(1, 1), .Cells(RowTableHdr1 - 1, ColShtHdrLast)).Copy _
Destination:=wshtDest.Cells(1, 1)
' Copy table header
.Range(.Cells(RowTableHdr1, 1), .Cells(RowTableHdr1 + 1, ColLast)).Copy _
Destination:=wshtDest.Cells(RowTableHdr1, 1)
RowDestNext = RowTableHdr1 + 2
' Copy rows for each section in critical path to destination worksheet
For InxSect = 0 To UBound(Section)
Set Rng = .Columns("A:A").Find(What:=Section(InxSect), LookAt:=xlWhole)
If Rng Is Nothing Then
Call MsgBox("I am unable to find the row(s) for Section" & _
Section(InxSect), vbOKOnly)
Else
Set Rng = Rng.MergeArea ' Expand to include all rows for section
' Copy all rows for section
Rng.EntireRow.Copy Destination:=wshtDest.Cells(RowDestNext, 1)
' Step output row number
RowDestNext = RowDestNext + Rng.Rows.Count
End If
Next
' Copy critical path row
.Rows(RowSrcLast).EntireRow.Copy Destination:=wshtDest.Cells(RowDestNext, 1)
RowDestNext = RowDestNext + 1
End With
' Add border at bottom of output table
With wshtDest
With .Range(.Cells(RowDestNext, 1), _
.Cells(RowDestNext, ColLast)).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 16
End With
End With
End Sub
New version of macro in response to request
Because the sections have different numbers of rows, no in situ sort is possible.
Version 1 solved this problem by copying required rows to a different worksheet. Version 2 solves this problem by copying them to a workarea below the original table but within the same worksheet. That is, a new table is built beneath the old.
Once the new table is complete, the old table is deleted to move the new table into the correct position.
Sub ertert()
Const ColLast As Long = 10
Const ColShtHdrLast As Long = 2
Const TableHdr1 As String = "Total Pressure Loss Calculations by Sections"
Dim ColCrnt As Long
Dim Section() As String
Dim CriticalPath As String
Dim InxSect As Long
Dim Rng As Range
Dim RowDestNext As Long
Dim RowDestStart As Long
Dim RowSrcLast As Long
Dim RowTableHdr1 As Long
Dim wsht As Worksheet
Set wsht = ActiveSheet
With wsht
' Extract critial path string and convert to array of Section numbers
RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
CriticalPath = .Cells(RowSrcLast, "A").Value
' Extract text before trailing total pressure loss
CriticalPath = Split(CriticalPath, ";")(0)
' Discard introductory text and trim spaces
CriticalPath = Trim(Split(CriticalPath, ":")(1))
Section = Split(CriticalPath, "-")
Set Rng = .Cells.Find(What:=TableHdr1)
If Rng Is Nothing Then
Call MsgBox("I am unable to find the row containing """ & _
TableHdr1 & """", vbOKOnly)
Exit Sub
End If
RowTableHdr1 = Rng.Row
' Because there is no fixed number of rows per section no in-situ sort is
' practical. Instead copy required rows in required section to destination
' area below existing area.
RowDestStart = RowSrcLast + 2
RowDestNext = RowDestStart
' Copy rows for each section in critical path to destination area
For InxSect = 0 To UBound(Section)
Set Rng = .Columns("A:A").Find(What:=Section(InxSect), LookAt:=xlWhole)
If Rng Is Nothing Then
Call MsgBox("I am unable to find the row(s) for Section" & _
Section(InxSect), vbOKOnly)
Else
Set Rng = Rng.MergeArea ' Expand to include all rows for section
' Copy all rows for section
Rng.EntireRow.Copy Destination:=.Cells(RowDestNext, 1)
' Step output row number
RowDestNext = RowDestNext + Rng.Rows.Count
End If
Next
' Copy critical path row
.Rows(RowSrcLast).EntireRow.Copy Destination:=.Cells(RowDestNext, 1)
RowDestNext = RowDestNext + 1
' Add border at bottom of output table
With .Range(.Cells(RowDestNext, 1), _
.Cells(RowDestNext, ColLast)).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 16
End With
' Now have new table on rows RowDestStart to RowDestNext-1.
' Delete rows RowTableHdr1+2 to RowDestStart-1 (old table) to
' move new table into desired position.
.Rows(RowTableHdr1 + 2 & ":" & RowDestStart - 1).EntireRow.Delete
End With
End Sub

Excel copy/sort data while counting/removing duplicates

Ok so I've searched and searched and can't quite find what I'm looking for.
I have a workbook and what I'm basically trying to do is take the entries from certain ranges (Sheet1 - E4:E12, E14:E20, I4:I7, I9:I12, I14:I17, & I19:I21) and put them in a separate list on Sheet2. I then want the new list on Sheet2 to be sorted by how many times an entry appeared on Sheet1 as well as display the amount.
example http://demonik.doomdns.com/images/excel.png
Obviously as can be seen by the ranges I listed above, this sample is much smaller lol, was just having trouble trying to figure out how to describe everything and figured an image would help.
Basically I am trying to use VBA (the update would be initialized by hitting a button) to copy data from Sheet1 and put all the ranges into one list in Sheet2 that is sorted by how many times it appeared on Sheet1, and then alphabetically.
If a better discription is needed just comment and let me know, I've always been horrible at trying to describe stuff like this lol.
Thanks in advance!
Another detail: I cant have it search for specific things as the data in the ranges on Sheet1 may change. Everything must be dynamic.
I started out with this data
and used the following code to read it into an array, sort the array, and count the duplicate values, then output the result to sheet2
Sub Example()
Dim vCell As Range
Dim vRng() As Variant
Dim i As Integer
ReDim vRng(0 To 0) As Variant
Sheets("Sheet2").Cells.Delete
Sheets("Sheet1").Select
For Each vCell In ActiveSheet.UsedRange
If vCell.Value <> "" Then
ReDim Preserve vRng(0 To i) As Variant
vRng(i) = vCell.Value
i = i + 1
End If
Next
vRng = CountDuplicates(vRng)
Sheets("Sheet2").Select
Range(Cells(1, 1), Cells(UBound(vRng), UBound(vRng, 2))) = vRng
Rows(1).Insert
Range("A1:B1") = Array("Entry", "Times Entered")
ActiveSheet.UsedRange.Sort Range("B1"), xlDescending
End Sub
Function CountDuplicates(List() As Variant) As Variant()
Dim CurVal As String
Dim NxtVal As String
Dim DupCnt As Integer
Dim Result() As Variant
Dim i As Integer
Dim x As Integer
ReDim Result(1 To 2, 0 To 0) As Variant
List = SortAZ(List)
For i = 0 To UBound(List)
CurVal = List(i)
If i = UBound(List) Then
NxtVal = ""
Else
NxtVal = List(i + 1)
End If
If CurVal = NxtVal Then
DupCnt = DupCnt + 1
Else
DupCnt = DupCnt + 1
ReDim Preserve Result(1 To 2, 0 To x) As Variant
Result(1, x) = CurVal
Result(2, x) = DupCnt
x = x + 1
DupCnt = 0
End If
Next
Result = WorksheetFunction.Transpose(Result)
CountDuplicates = Result
End Function
Function SortAZ(MyArray() As Variant) As Variant()
Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim x As Integer
Dim Temp As String
First = LBound(MyArray)
Last = UBound(MyArray)
For i = First To Last - 1
For x = i + 1 To Last
If MyArray(i) > MyArray(x) Then
Temp = MyArray(x)
MyArray(x) = MyArray(i)
MyArray(i) = Temp
End If
Next
Next
SortAZ = MyArray
End Function
End Result:
Here is a possible solution that I have started for you. What you are asking to be done gets rather complicated. Here is what I have so far:
Option Explicit
Sub test()
Dim items() As String
Dim itemCount() As String
Dim currCell As Range
Dim currString As String
Dim inArr As Boolean
Dim arrLength As Integer
Dim iterator As Integer
Dim x As Integer
Dim fullRange As Range
Set fullRange = Range("E1:E15")
iterator = 0
For Each cell In fullRange 'cycle through the range that has the values
inArr = False
For Each currString In items 'cycle through all values in array, if
'values is found in array, then inArr is set to true
If currCell.Value = currString Then 'if the value in the cell we
'are currently checking is in the array, then set inArr to true
inArr = True
End If
Next
If inArr = False Then 'if we did not find the value in the array
arrLength = arrLength + 1
ReDim Preserve items(arrLength) 'resize the array to fit the new values
items(iterator) = currCell.Value 'add the value to the array
iterator = iterator + 1
End If
Next
'This where it gets tricky. Now that you have all unique values in the array,
'you will need to count how many times each value is in the range.
'You can either make another array to hold those values or you can
'put those counts on the sheet somewhere to store them and access them later.
'This is tough stuff! It is not easy what you need to be done.
For x = 1 To UBound(items)
Next
End Sub
All that this does so far is get unique values into the array so that you can count how many times each one is in the range.

Resources