I want to list rows from Sheet1 to Sheet2 based on a criteria, move on to next criteria once there is no more rows to copy according to the first criteria and also separate the copied rows by headers.
Sheet1 contains an unsorted list of projects, where I want to be able to add and remove projects whenever. I also want to categorize projects into different types. Sheet1 would look like this:
ProjectID ProjectName Type Cost
1 ProjectA Development -120
2 ProjectB Development -250
3 ProjectC Maintenance -30
I would then like to copy the data via VBA to Sheet2 in the following format:
Maintenance Projects
ProjectID ProjectName Type Cost
3 ProjectC Maintenance -30
Development Projects
ProjectID ProjectName Type Cost
1 ProjectA Development -120
2 ProjectB Development -250
I've been trying to look for a solution but haven't found one that would suit my need and I am not a very experienced VBA user. Any tips or hints on what method to use here?
This will copy your data from sheet1 to sheet2 assuming sheet2 is blank in the format that you requested.
Sub SplitData_Click()
Dim dicType As Object
Set dicType = CreateObject("scripting.dictionary")
Dim i As Integer
Dim lstRow As Long
Dim val As String
lstRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 4).End(xlUp).Row
Dim projects() As Variant
ReDim projects(0 To lstRow - 2, 0 To 3) ' I like 0 based arrays
' Populate the dictionary with the unique types
For i = 2 To lstRow
projects(i - 2, 0) = Range("A" & i) ' ProjectID
projects(i - 2, 1) = Range("B" & i) ' ProjectName
projects(i - 2, 2) = Range("C" & i) ' Type
projects(i - 2, 3) = Range("D" & i) ' Cost
val = Range("C" & i)
If dicType.Exists(val) Then
dicType.Item(val) = dicType.Item(val) + 1
Else
dicType.Add val, 1
End If
Next i
Dim header() As Variant
ReDim header(0 To 3)
header(0) = "ProjectId"
header(1) = "ProjectName"
header(2) = "Type"
header(3) = "Cost"
Sheets("Sheet2").Select
' loop through each type and build its structure on sheet 2
Dim key As Variant
For Each key In dicType
If Range("A1") = "" Then
Range("A1").Value = key & " Projects"
Else
lstRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 2
Range("A" & lstRow).Value = key & " Projects"
End If
lstRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 1
Range("A" & lstRow).Value = header(0)
Range("B" & lstRow).Value = header(1)
Range("C" & lstRow).Value = header(2)
Range("D" & lstRow).Value = header(3)
For i = 0 To UBound(projects)
lstRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row + 1
If projects(i, 2) = key Then
Range("A" & lstRow).Value = projects(i, 0)
Range("B" & lstRow).Value = projects(i, 1)
Range("C" & lstRow).Value = projects(i, 2)
Range("D" & lstRow).Value = projects(i, 3)
End If
Next i
Debug.Print key
Next key
End Sub
Related
I need to maintain an old system written in vb6.
Currently in this system there is an sorted list of integers with approximately 1 million items. To locate an item, I use binary search to obtain the shortest response time.
I need to add new items to this list in runtime and these items are added to the end of the list, however the binary search requires that the list is sorted.
Currently the list is a User-Defined Data Types and the ordering is by the Code field
Private Type ProductDetails
ProdID as String
ProdName as String
Code as Double
End Type
The main requirement is the response time to find an item in whatever position it is.
Any idea or tip of this implementation will be very welcome.
thankful
Nadia
Fastest way is with collection:
this is output from test sub:
creating 1.000.000 long product list
**done in 16,6219940185547 seconds**
searching list
fastest way (instant) if you know index (if you have ID)
ID0500000
500000 ID0500000 This is product 500000
**done in 0 seconds**
searching by name (find item 500.000 which is in the middle od list
500000 ID0500000 This is product 500000
**done in 0,425003051757813 seconds**
listing all items that have '12345' in their name
12345 ID0012345 This is product 12345
112345 ID0112345 This is product 112345
123450 ID0123450 This is product 123450
123451 ID0123451 This is product 123451
123452 ID0123452 This is product 123452
123453 ID0123453 This is product 123453
123454 ID0123454 This is product 123454
123455 ID0123455 This is product 123455
123456 ID0123456 This is product 123456
123457 ID0123457 This is product 123457
123458 ID0123458 This is product 123458
123459 ID0123459 This is product 123459
212345 ID0212345 This is product 212345
312345 ID0312345 This is product 312345
412345 ID0412345 This is product 412345
512345 ID0512345 This is product 512345
612345 ID0612345 This is product 612345
712345 ID0712345 This is product 712345
812345 ID0812345 This is product 812345
912345 ID0912345 This is product 912345
**done in 2,05299377441406 seconds**
so, if you load list in memory at the beginning of the app it should search fast enough
'following this code goes in module:
Option Explicit
Private Type ProductDetails
ProdID As String
ProdName As String
Code As Double
End Type
Dim pdList As New Collection
Function genRndNr(nrPlaces) 'must be more then 10
Dim prefix As String
Dim suffix As String
Dim pon As Integer
prefix = Right("0000000000" + CStr(DateDiff("s", "2020-01-01", Now)), 10)
suffix = Space(nrPlaces - 10)
For pon = 1 To Len(suffix)
Randomize
Randomize Rnd * 1000000
Mid(suffix, pon, 1) = CStr(Int(Rnd * 10))
Next
genRndNr = prefix + suffix
End Function
Sub test()
Dim pd As ProductDetails
Dim pdData As Variant
Dim query As String
Dim pon As Long
Dim startT As Long
Debug.Print "creating 1.000.000 long product list"
startT = Timer
For pon = 1 To 1000000
pd.Code = pon
pd.ProdID = "ID" + Right("0000000000" + CStr(pon), 7) 'id= from ID0000001 to ID1000000
pd.ProdName = "This is product " + CStr(pon) 'product name
pdData = Array(pd.Code, pd.ProdID, pd.ProdName) 'create array
pdList.Add pdData, pd.ProdID 'adding array to collection (pd.ID=index)
Next
Debug.Print "done in " + CStr(Timer - startT) + " seconds"
Debug.Print
Debug.Print
Debug.Print "searching list"
startT = Timer
Debug.Print "fastest way (instant) if you know index (if you have ID)"
query = "ID0500000"
pdData = pdList(query)
pd.Code = pdData(0)
pd.ProdID = pdData(1)
pd.ProdName = pdData(2)
Debug.Print query
Debug.Print pd.Code, pd.ProdID, pd.ProdName
Debug.Print "done in " + CStr(Timer - startT) + " seconds"
Debug.Print
Debug.Print
Debug.Print "searching by name (find item 500.000 which is in the middle od list"
startT = Timer
query = "This is product 500000"
For Each pdData In pdList
If query = pdData(2) Then
pd.Code = pdData(0)
pd.ProdID = pdData(1)
pd.ProdName = pdData(2)
Exit For
End If
Next
Debug.Print pd.Code, pd.ProdID, pd.ProdName
Debug.Print "done in " + CStr(Timer - startT) + " seconds"
Debug.Print
Debug.Print
Debug.Print "listing all items that have '12345' in their name"
startT = Timer
query = "*12345*"
For Each pdData In pdList
If pdData(2) Like query Then
pd.Code = pdData(0)
pd.ProdID = pdData(1)
pd.ProdName = pdData(2)
Debug.Print pd.Code, pd.ProdID, pd.ProdName
End If
Next
Debug.Print "done in " + CStr(Timer - startT) + " seconds"
Debug.Print
Debug.Print
'clear pd memory buffer
Set pdList = Nothing
End Sub
I have the following problem:
I have to sort the data of a recordset with a hierarchy.
This is the data as it comes from the database.
You see there are two columns, POS and PARENT.
These values must be related to each other.
If PARENT is 0, then the value in the new sort simply gets a consecutive number. In this case 1-3.
The other values each get a new consecutive number, based on the parent.
I'm pretty sure I could solve this problem in C#, but in this case VB6 is mandatory. Unfortunately I have extreme problems solving the problem with VB6.
This looks like a linked list exercise. You can create a clsListItem class that has a FirstChild object and a NextItem object:
Public Position As Integer
Public Hierarchy As String
Public FirstChild As clsListItem
Public NextItem As clsListItem
As you go down the list, you create a new object and look for its parent. You then check if the FirstChild of the parent exists or not. If it doesn't, you Set the object as the FirstChild, otherwise you navigate through children objects using NextItem until NextItem is Nothing. You then Set the object as NextItem:
Public Sub Sort(ByVal p_sList As String)
Dim arrLines
Dim arrFields
Dim iCounter As Integer
Dim objItem As clsListItem
Dim objParent As clsListItem
Dim objChild As clsListItem
Dim iPosition As Integer
Dim iParent As Integer
Dim iParentIndex As Integer
Dim iChildIndex As Integer
' Split values into lines
arrLines = Split(p_sList, vbCrLf)
' Initialize Parent Index
iParentIndex = 1
For iCounter = 1 To UBound(arrLines) + 1
arrFields = Split(arrLines(iCounter - 1), ",")
iPosition = arrFields(0)
iParent = arrFields(1)
' Get Item
Set objItem = GetItem(iPosition)
If iParent = 0 Then
' This is a top-level item
objItem.Hierarchy = iParentIndex
iParentIndex = iParentIndex + 1
Else
' Get Parent
Set objParent = GetItem(iParent)
' Initialize Child Index
iChildIndex = 1
If objParent.FirstChild Is Nothing Then
' We are the first child
Set objParent.FirstChild = objItem
Else
' Find last child
Set objChild = objParent.FirstChild
iChildIndex = iChildIndex + 1
Do While Not objChild.NextItem Is Nothing
Set objChild = objChild.NextItem
iChildIndex = iChildIndex + 1
Loop
Set objChild.NextItem = objItem
End If
objItem.Hierarchy = objParent.Hierarchy & "." & iChildIndex
End If
Next
Dim sMessage As String
For iCounter = 1 To colListItems.Count
Set objItem = colListItems.item(iCounter)
With objItem
sMessage = sMessage & .Position & ": " & .Hierarchy & vbCrLf
End With
Next
MsgBox sMessage
End Sub
That should organize all your data into objects with the desired hierarchy.
Helper function to Get/Create items:
Public Function GetItem(ByVal p_iPosition As Integer) As clsListItem
Dim objItem As clsListItem
On Error GoTo ItemNotFound
Set objItem = colListItems.item("P" & p_iPosition)
GoTo ReturnItem
ItemNotFound:
Set objItem = New clsListItem
objItem.Position = p_iPosition
colListItems.Add objItem, "P" & p_iPosition
ReturnItem:
Set GetItem = objItem
End Function
Finally, the code I used to create the table of values you have (double-check it, could be typo):
Private Function AddPair(ByVal p_sList As String, ByVal p_iPos As Integer, ByVal p_iParent As Integer) As String
Dim sReturn As String
sReturn = p_sList
If sReturn <> "" Then sReturn = sReturn & vbCrLf
sReturn = sReturn & p_iPos & "," & p_iParent
AddPair = sReturn
End Function
and this is the main subroutine:
Private Sub Form_Load()
Dim list As String
list = AddPair(list, 1, 0)
list = AddPair(list, 13, 0)
list = AddPair(list, 16, 0)
list = AddPair(list, 2, 1)
list = AddPair(list, 12, 1)
list = AddPair(list, 3, 2)
list = AddPair(list, 4, 2)
list = AddPair(list, 5, 2)
list = AddPair(list, 6, 2)
list = AddPair(list, 7, 2)
list = AddPair(list, 8, 7)
list = AddPair(list, 11, 7)
list = AddPair(list, 9, 8)
list = AddPair(list, 10, 8)
list = AddPair(list, 14, 13)
list = AddPair(list, 15, 13)
list = AddPair(list, 17, 16)
list = AddPair(list, 18, 16)
Sort (list)
End Sub
The below code will split 1 cell into 3 or 4 column based on a pattern of 6chr,5chr,4chr,5+chr. The below also needs to be available on all open workbooks and work from the user selection.
How to fix a bug that after the first splitting of the cell is done and by mistake you run it again will override the data?
Class Module
Option Explicit
'Rename this Class Module cFabric
Private pStyle As String
Private pFabric As String
Private pColour As String
Private pSize As String
Public Property Get Style() As String
Style = pStyle
End Property
Public Property Let Style(Value As String)
pStyle = Value
End Property
Public Property Get Fabric() As String
Fabric = pFabric
End Property
Public Property Let Fabric(Value As String)
pFabric = UCase(Value)
End Property
Public Property Get Colour() As String
Colour = pColour
End Property
Public Property Let Colour(Value As String)
pColour = Value
End Property
Public Property Get Size() As String
Size = pSize
End Property
Public Property Let Size(Value As String)
pSize = Value
End Property
Regular Module
Option Explicit
Sub Fabrics()
Dim wsSrc As Workbook, wsRes As Workbook
Dim vSrc As Variant, vRes As Variant, rRes As Range
Dim RE As Object, MC As Object
Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?"
'Group 1 = style
'Group 2 = fabric
'Group 3 = colour
'Group 4 = size
Dim colF As Collection, cF As cFabric
Dim I As Long
Dim S As String
Dim V As Variant
'Set source and results worksheets and ranges
Set wsSrc = ActiveWorkbook
Set wsRes = ActiveWorkbook
Set rRes = wsRes.Application.Selection
'Read source data into array
vSrc = Application.Selection
'Initialize the Collection object
Set colF = New Collection
'Initialize the Regex Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.MultiLine = True
.Pattern = sPat
'Test for single cell
If Not IsArray(vSrc) Then
V = vSrc
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = V
End If
'iterate through the list
For I = 1 To UBound(vSrc, 1)
S = vSrc(I, 1)
Set cF = New cFabric
If .test(S) = True Then
Set MC = .Execute(S)
With MC(0)
cF.Style = .submatches(0)
cF.Fabric = .submatches(1)
cF.Colour = .submatches(2)
cF.Size = .submatches(3)
End With
Else
cF.Style = S
End If
colF.Add cF
Next I
End With
'create results array
'Exit if no results
If colF.Count = 0 Then Exit Sub
ReDim vRes(1 To colF.Count, 1 To 4)
'Populate the rest
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End With
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
rRes.Value = vRes
End Sub
Credits for the above goes to #Ron Rosenfeld for the project!
One way to tell if the entry has been previously split is as follows
If the regex.test fails, then
If the results line passes, then the item has been previously split
if not, then it is a blank, or a malformed entry
Note that a lot of this could be avoided if you were not overwriting your original data. I would recommend against overwriting your data both for audit and debugging purposes, but the below should help in case you cannot change that.
You just need to make some small changes in the logic where we checked for the malformed entry originally. As well as reading in the "possible" results array into vSrc so that we have the potentially split data to compare:
Option Explicit
Sub Fabrics()
'assume data is in column A
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim vSrc As Variant, vRes As Variant, rRes As Range
Dim RE As Object, MC As Object
Const sPat As String = "^(.{6})\s*(.{5})\s*(.{4})(?:.*1/(\S+))?"
'Group 1 = style
'Group 2 = fabric
'Group 3 = colour
'Group 4 = size
Dim colF As Collection, cF As cFabric
Dim I As Long
Dim S As String
Dim V As Variant
'Set source and results worksheets and ranges
Set wsSrc = ActiveSheet
Set wsRes = ActiveSheet
Set rRes = Selection
'Read source data into array
vSrc = Selection.Resize(columnsize:=4)
'Initialize the Collection object
Set colF = New Collection
'Initialize the Regex Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.MultiLine = True
.Pattern = sPat
'iterate through the list
'Test for single cell
If Not IsArray(vSrc) Then
V = vSrc
ReDim vSrc(1 To 1, 1 To 1)
vSrc(1, 1) = V
End If
For I = 1 To UBound(vSrc, 1)
S = vSrc(I, 1)
Set cF = New cFabric
If .test(S) = True Then
Set MC = .Execute(S)
With MC(0)
cF.Style = .submatches(0)
cF.Fabric = .submatches(1)
cF.Colour = .submatches(2)
cF.Size = .submatches(3)
End With
ElseIf .test(vSrc(I, 1) & vSrc(I, 2) & vSrc(I, 3)) = False Then
cF.Style = S
Else
cF.Style = vSrc(I, 1)
cF.Fabric = vSrc(I, 2)
cF.Colour = vSrc(I, 3)
cF.Size = vSrc(I, 4)
End If
colF.Add cF
Next I
End With
'create results array
'Exit if not results
If colF.Count = 0 Then Exit Sub
ReDim vRes(1 To colF.Count, 1 To 4)
'Populate
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End With
Next V
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.Clear
.NumberFormat = "#"
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
Disregarding the previous regex/class method,
Option Explicit
Sub Fabrics_part_Deux()
Dim a As Long, b As Long
With Worksheets("Sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp).Offset(0, 3))
With .Columns("B")
.Offset(1, 0).Replace what:=Chr(32), replacement:=vbNullString, lookat:=xlPart
End With
.AutoFilter field:=2, Criteria1:="<>"
.AutoFilter field:=3, Criteria1:=""
With .Resize(.Rows.Count - 1, 1).Offset(1, 1)
If CBool(Application.Subtotal(103, .Cells)) Then
With .SpecialCells(xlCellTypeVisible)
For a = 1 To .Areas.Count
With .Areas(a).Cells
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(6, 1), Array(11, 1), Array(15, 2))
For b = 1 To .Rows.Count
.Cells(b, 2) = UCase$(.Cells(b, 2).Value2)
If CBool(InStr(1, .Cells(b, 4).Value2, Chr(47), vbBinaryCompare)) Then
.Cells(b, 4) = Trim(Split(.Cells(b, 4), Chr(47))(1))
End If
Next b
End With
Next a
End With
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
In your code to output to the spreadsheet, you need to check for empty strings
I = 0
For Each V In colF
I = I + 1
With V
vRes(I, 1) = .Style
If len(.Fabric) > 0 then
vRes(I, 2) = .Fabric
vRes(I, 3) = .Colour
vRes(I, 4) = .Size
End If
End With
Next V
I am trying to compare two months sales to each other in excel in the most automated way possible (just so it will be quicker for future months)
This months values are all worked out through formulae and last months will be copy and pasted into D:E. However as you can see there are some customers that made purchases last month and then did not this month (and vice versa). I basically need to be have all CustomerID's matching row by row. So for example it to end up like this:
Can anyone think of a good way of doing this without having to do it all manually? Thanks
Use the SUMIFS function or VLOOKUP. Like this:
http://screencast.com/t/VTBZrfHjo8tk
You should just have your entire customer list on one sheet and then add up the values associated with them month over month. The design you are describing is going to be a nightmare to maintain over time and serves no purpose. I can understand you would like to see the customers in a row like that, which is why I suggest SUMIFS.
This option compare only two columns, I think you do to think anoter way,
first I will add the date/month and then you can add down the next month value:
then you can use a simply pivot to see more month in the some time
any case if you want to format your two columns, you can use this code (you will to update with you reference, I used the date from your img example)
Sub OrderMachColumns()
Dim lastRow As Integer
Dim sortarray(1 To 2, 1 To 2) As String
Dim x As Long, y As Long
Dim TempTxt10 As String
Dim TempTxt11 As String
Dim TempTxt20 As String
Dim TempTxt22 As String
lastRow = Range("A3").End(xlDown).Row ' I use column A, same your example
For x = 3 To lastRow * 2
Cells(x, 1).Select
If Cells(x, 1) = "" Then GoTo B
If Cells(x, 4) = "" Then GoTo A
If Cells(x, 1) = Cells(x, 4) Then
Else
If Cells(x, 1).Value = Cells(x - 1, 4).Value Then
Range(Cells(x - 1, 4), Cells(x - 1, 5)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ElseIf Cells(x, 1).Value = Cells(x + 1, 4).Value Then
Range(Cells(x, 1), Cells(x, 2)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Else
sortarray(1, 1) = Cells(x, 1).Value
sortarray(1, 2) = "Cells(" & x & ", 1)"
sortarray(2, 1) = Cells(x, 4).Value
sortarray(2, 2) = "Cells(" & x & ", 4)"
For Z = LBound(sortarray) To UBound(sortarray)
For y = Z To UBound(sortarray)
If UCase(sortarray(y, 1)) > UCase(sortarray(Z, 1)) Then
TempTxt11 = sortarray(Z, 1)
TempTxt12 = sortarray(Z, 2)
TempTxt21 = sortarray(y, 1)
TempTxt22 = sortarray(y, 2)
sortarray(Z, 1) = TempTxt21
sortarray(y, 1) = TempTxt11
sortarray(Z, 2) = TempTxt22
sortarray(y, 2) = TempTxt12
End If
Next y
Next Z
Select Case sortarray(1, 2)
Case "Cells(" & x & ", 1)"
Range(Cells(x, 1), Cells(x, 2)).Select
Case "Cells(" & x & ", 4)"
Range(Cells(x, 4), Cells(x, 5)).Select
End Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End If
End If
A:
Next x
B:
End Sub
I have a combobox filled with values. I want to select a value in the combo box and click the "Add" button to place this value into the some cells below. I can add one item to my list using the following code, but I want to be able to add multiple items. I feel that I am very close, I just need a few tweaks!
Private Sub CommandButtonAddItem_Click()
Dim ws As Worksheet
Dim box As ComboBox
Dim food As String
Dim num As Integer
num = 19
Set ws = Worksheets("sheet1")
Set box = ws.OLEObjects("ComboBox1").Object
food = box.Value
Worksheets("sheet1").Cells(num, 1) = food
If Worksheets("sheet1").Cells(num, 1) = " " Then
Worksheets("sheet1").Cells(num, 1) = food
num = num + 1
End If
End Sub
Try THIS!
If the "default" cell is already occupied, it'll keep going down untill it finds one that's not empty, to then put the value in that cell.
Private Sub CommandButtonAddItem_Click()
Dim ws As Worksheet
Dim box As ComboBox
Dim food As String
Dim num As Integer
num = 19
Set ws = Worksheets("sheet1")
Set box = ws.OLEObjects("ComboBox1").Object
food = box.Value
While Worksheets("sheet1").Cells(num, 1) <> ""
num = num + 1
Wend
Worksheets("sheet1").Cells(num, 1) = food
End If
End Sub