I am making a music player using the list control. I want to let the user change the name of the song on the list, but i want some property of THAT list item to contain its path.
Please help me in this. Any kind of help will be appreciated. Thanks in advance.
EDIT
Private Sub AddToList(ByVal txtFileName As String)
Dim I As Integer
Dim blnFileAlreadyexists As Boolean
txtFileName = Trim(txtFileName)
If txtFileName <> "" Then
blnFileAlreadyexists = False
For I = 0 To List1.ListCount - 1
If Trim(List1.List(I)) = txtFileName Then
blnFileAlreadyexists = True
End If
Next
If Not blnFileAlreadyexists Then
List1.AddItem (txtFileName)
List1.ItemData (txtFileName)
End If
End If
End Sub
For a listbox, after you add an item set its x.itemdata(x.newindex) to the index of an array (or UDT array) that contains the corresponding data.
For a listview you can similarly use an individual items .Tag or .Key to store an array (or collection) index.
Linking a listbox example;
Option Explicit
Private Type TFileData
OriginalFilePath As String
ListBoxIndex As Integer
MoreBlaBla As String
'//any more members
End Type
Private maFiles() As TFileData
Private Sub Form_Load()
'//initial alloc
ReDim maFiles(0)
AddToList "AAAA"
AddToList "BBBB"
AddToList "AAAA"
AddToList "CCCC"
'//test by looping listbox;
Dim i As Integer
For i = 0 To List1.ListCount - 1
MsgBox List1.List(i) & " - " & maFiles(List1.ItemData(i)).OriginalFilePath
Next
'// a better type centric test;
For i = 0 To UBound(maFiles) - 1
MsgBox maFiles(i).OriginalFilePath & " - List entry: " & List1.List(maFiles(i).ListBoxIndex)
Next
End Sub
Private Sub AddToList(ByVal txtFileName As String)
Dim i As Integer
Dim blnFileAlreadyexists As Boolean
txtFileName = Trim(txtFileName)
If txtFileName <> "" Then
blnFileAlreadyexists = False
For i = 0 To List1.ListCount - 1
If Trim(List1.List(i)) = txtFileName Then
blnFileAlreadyexists = True
End If
Next
If Not blnFileAlreadyexists Then
'//add to list
List1.AddItem (txtFileName)
'//store the original value in the array;
maFiles(UBound(maFiles)).OriginalFilePath = "TEST: " & txtFileName
'//store the index of the array in the list;
List1.ItemData(List1.NewIndex) = UBound(maFiles)
'//or better store in the type
maFiles(UBound(maFiles)).ListBoxIndex = List1.NewIndex
'//increment the array for the next item;
ReDim Preserve maFiles(UBound(maFiles) + 1)
End If
End If
End Sub
Related
I have list1, treeview, list2
list1 has items
treeview1 has items
list2 empty or has items populating over time
Now I want to loop through list1 compare it with list2 and if items do not match then remove the items from treeview1,list1.
The small problem I am having now is list1 ends up keeping 1 unwanted item.
list1 treeview1 and list2 over time has same items populated but list2 sometimes may not contain the same value as list1 this is why I need to loop and match strings. If not found then remove the strings from list1 and treeview1 the same items only.
This code below you can paste it into fresh vb6 project just add 1 treeview1 list1 and list2 and 2 command button
Private Sub Command1_Click()
List1.AddItem "dezzzzz"
TreeView1.Nodes.Add , , , "dezzzzz" & "/" & "General"
List1.AddItem "tammy8123"
TreeView1.Nodes.Add , , , "tammy8123" & "/" & "General"
List1.AddItem "sarah7232"
TreeView1.Nodes.Add , , , "sarah7232" & "/" & "General"
List2.AddItem "tammy8123"
End Sub
Private Sub Command2_Click()
Dim i As Integer, ii As Integer
Dim iii As Integer, demopacket() As String
For ii = List1.ListCount - 1 To 0 Step -1
Dim lstUserspacket() As String
lstUserspacket() = Split(List1.List(ii), "/")
For iii = 1 To TreeView1.Nodes.Count
demopacket() = Split(TreeView1.Nodes(iii).Text, "/")
For i = List2.ListCount - 1 To 0 Step -1
Dim listpacket() As String
listpacket() = Split(List2.List(i), "/")
If listpacket(0) = demopacket(0) Then
Exit For
End If
Next
If i = -1 Then
On Error Resume Next
List1.RemoveItem ii
TreeView1.Nodes.Remove iii
End If
Next
Next
End Sub
Private Sub Form_Load()
Call Command1_Click
End Sub
My first thought was to simply find the issue with the code you provided. My next thought was realizing the code was too complex for a rather simple task. The code could be as simple as:
Private Sub Command2_Click()
Dim i As Integer
For i = List1.ListCount - 1 To 0 Step -1
If Not ExistsInList(List2, List1.List(i)) Then
TreeView1.Nodes.Remove FindInTree(TreeView1, List1.List(i))
List1.RemoveItem FindInList(List1, List1.List(i))
End If
Next
End Sub
Of course, the controls in question do not provide an Exists or Find method. But it is not a hard task to create you own. If you place the following functions in a Utility module then you can use them in other projects, too:
Public Function ExistsInList(ByVal ListBox As ListBox, ByVal Item As String) As Boolean
Dim i As Integer
For i = 0 To ListBox.ListCount - 1
If ListBox.List(i) = Item Then
ExistsInList = True
Exit Function
End If
Next
End Function
Public Function FindInList(ByVal ListBox As ListBox, ByVal Item As String) As Integer
Dim i As Integer
For i = 0 To ListBox.ListCount - 1
If ListBox.List(i) = Item Then
FindInList = i
Exit Function
End If
Next
End Function
Public Function FindInTree(ByVal TreeView As TreeView, ByVal Item As String) As Integer
Dim i As Integer
For i = 1 To TreeView.Nodes.Count
If InStr(1, TreeView.Nodes(i).Text, Item) > 0 Then
FindInTree = i
Exit Function
End If
Next
End Function
I have a code which I would like to use on multiple sheets, except one sheet. But applying the code to alle sheets is also fine.
Here is the code that I would like to adjust. I am have currently applied it to Excel 2011 in OS X , but I would like to use it for Excel 2010 in Windows.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim the_selection As String
Dim month_in_review As String
the_selection = Sheet1.Range("A1")
Dim Rep As Integer
For Rep = 2 To 379
the_column = GetColumnLetter_ByInteger(Rep)
month_in_review = Sheet1.Range(the_column & "1")
If the_selection = month_in_review Then
Sheet1.Range(the_column & ":" & the_column).EntireColumn.Hidden = False
Else
Sheet1.Range(the_column & ":" & the_column).EntireColumn.Hidden = True
End If
Next Rep
End If
End Sub
In the module I have the following code:
Public Function GetColumnLetter_ByInteger(what_number As Integer) As String
GetColumnLetter_ByInteger = ""
MyColumn_Integer = what_number
If MyColumn_Ineger <= 26 Then
column_letter = ChrW(64 + MyColumn_Integer)
End If
If MyColumn_Integer > 26 Then
column_letter = ChrW(Int((MyColumn_Integer - 1) / 26) + 64) & ChrW(((MyColumn_Integer - 1) Mod 26) + 65)
End If
GetColumnLetter_ByInteger = column_letter
End Function
If you're asking for one sheet to detect the change in cell "A1" and then to hide/unhide columns on multiple sheets then the prior answers to your question will serve you nicely.
If, on the other hand, you're asking to detect a change in cell "A1" on any sheet and then to hide/unhide columns on just the changed sheet, then the code below will work for you. It accesses the Workbook_SheetChanged event at Workbook level.
A few points about your code:
You can reference cells using their integer or address values with the .Cell property, so Sheet1.Cells(1, 1) is the same as Sheet1.Cells(1, "A"). The same applies to the .Columns property. So there's no real need to convert your integer values to a string. See #Florent B's answer for a good example of this.
Wherever possible, minimise looping sheet interactions as these are very time-consuming. So rather than loop through the columns and hide/unhide each one individually, you could assign them to ranges within your loop and then hide/unhide the ranges all in one go at the end of your loop. If you must interact with the sheet on each iteration of your loop, then set the Application.ScreenUpdating property to false before the start of your loop. There's an example of this property in the sample code below.
Put this in your Workbook module:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Const TARGET_ADDRESS As String = "A1"
Dim cell As Range
Dim hiddenCols As Range
Dim unhiddenCols As Range
Dim selectedMonth As String
Dim monthInReview As String
Dim c As Integer
'Ignore event if not a target worksheet
If Sh.Name = "Not Wanted" Then Exit Sub
'Ignore event if not in target range
Set cell = Target.Cells(1)
If cell.Address(False, False) <> TARGET_ADDRESS Then Exit Sub
'Criteria met, so handle event
selectedMonth = CStr(cell.Value)
For c = 2 To 379
Set cell = Sh.Cells(1, c)
monthInReview = CStr(cell.Value)
'Add cell to hidden or unhidden ranges
If monthInReview = selectedMonth Then
If unhiddenCols Is Nothing Then
Set unhiddenCols = cell
Else
Set unhiddenCols = Union(unhiddenCols, cell)
End If
Else
If hiddenCols Is Nothing Then
Set hiddenCols = cell
Else
Set hiddenCols = Union(hiddenCols, cell)
End If
End If
Next
'Hide and unhide the cells
Application.ScreenUpdating = False 'not really needed here but given as example
If Not unhiddenCols Is Nothing Then
unhiddenCols.EntireColumn.Hidden = False
End If
If Not hiddenCols Is Nothing Then
hiddenCols.EntireColumn.Hidden = True
End If
Application.ScreenUpdating = True
End Sub
You can use a for each loop to loop through all the Worksheets, and check the worksheet name if it should be skipped. Then apply your code onto the sheet selected.
Something like:
Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Skip Sheet" Then
Dim the_selection As String
Dim month_in_review As String
the_selection = ws.Range("A1")
Dim Rep As Integer
For Rep = 2 To 379
the_column = GetColumnLetter_ByInteger(Rep)
month_in_review = ws.Range(the_column & "1")
If the_selection = month_in_review Then
ws.Range(the_column & ":" & the_column).EntireColumn.Hidden = False
Else
ws.Range(the_column & ":" & the_column).EntireColumn.Hidden = True
End If
Next Rep
End If
Next ws
End If
End Sub
I wasn't entirely sure what you wished to achieve, so i put ws in the place of Sheet1.
This example will show/hide the columns in all the other sheets if the first cell of the column match/differ with the cell A1 of the sheet where this code is placed:
Private Sub Worksheet_Change(ByVal Target As Range)
' exit if not cell A1
If Target.row <> 1 Or Target.column <> 1 Then Exit Sub
Dim sheet As Worksheet
Dim the_selection As String
Dim month_in_review As String
Dim column As Integer
the_selection = Target.Value
' iterate all the sheets
For Each sheet In ThisWorkbook.Worksheets
' skip this sheet
If Not sheet Is Me Then
' iterate the columns
For column = 2 To 379
' get the first cell of the column
month_in_review = sheet.Cells(1, column).Value
' hide or show the column if it's a match or not
sheet.Columns(column).Hidden = month_in_review <> the_selection
Next
End If
Next
End Sub
Below code works great as expected the only downside is its slow because I am using this to search for all the instances of the substring and delete the Entire row if found in any cell of the whole workbook.
Aim is simple just delete the entirerow if the entered string is found in any cell string
Dim wo As Worksheet, ws As Worksheet
Dim I As Long, j As Long, m As Long
Dim toFind As String, testStr As String
Dim pos As Long
Dim lstRow As Long, cutRow As Long
Dim WS_Count As Integer
Dim Cell As Range
Option Compare Text
Option Explicit
Sub SearchDelete()
toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
j = 0
If toFind = "" Then
MsgBox "Empty String Entered.Exiting Sub Now."
Exit Sub
Else
WS_Count = ActiveWorkbook.Worksheets.Count
'Begin the loop.
For I = 1 To WS_Count
Label1:
For Each Cell In Worksheets(I).UsedRange.Cells
If Trim(Cell.Text) <> "" Then
pos = 0
pos = InStr(1, Trim(Cell.Text), toFind, vbTextCompare)
If pos > 0 Then 'match Found'
cutRow = Cell.Row
Worksheets(I).Rows(cutRow).EntireRow.Delete
j = j + 1
GoTo Label1
Else: End If
Else: End If
Next Cell
Next I
End If
MsgBox "Total " & j & " Rows were deleted!"
End Sub
Individual operations are pretty much always slower than bulk operations and the Range.Delete method is no exception. Collecting the matching rows with a Union method and then performing the removal en masse will significantly speed up the operation.
Temporarily suspending certain application environment handlers will also help things along. You do not need Application.ScreenUpdating active while you are removing rows; only after you have completed the operation.
Option Explicit
Option Compare Text
Sub searchDelete()
Dim n As Long, w As Long
Dim toFind As String, addr As String
Dim fnd As Range, rng As Range
toFind = InputBox("Enter the substring you want to search for.", "Welcome", "AAAA")
toFind = Trim(toFind)
If Not CBool(Len(toFind)) Then
MsgBox "Empty String Entered.Exiting Sub Now."
GoTo bm_Safe_Exit
End If
'appTGGL bTGGL:=False 'uncomment this line when you have finsihed debugging
With ActiveWorkbook
For w = 1 To .Worksheets.Count
With .Worksheets(w)
Set fnd = .Cells.Find(what:=toFind, lookat:=xlPart, _
after:=.Cells.SpecialCells(xlCellTypeLastCell))
If Not fnd Is Nothing Then
Set rng = .Rows(fnd.Row)
n = n + 1
addr = fnd.Address
Do
If Intersect(fnd, rng) Is Nothing Then
n = n + 1
Set rng = Union(rng, .Rows(fnd.Row))
End If
Set fnd = .Cells.FindNext(after:=fnd)
Loop Until addr = fnd.Address
Debug.Print rng.Address(0, 0)
rng.Rows.EntireRow.Delete
End If
End With
Next w
End With
Debug.Print "Total " & n & " rows were deleted!"
bm_Safe_Exit:
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
Debug.Print Timer
End Sub
The answer to your question: "How to speed up this code to find and delete rows if a substring is found" is - DON'T repeat the search from the top of the sheet after you found and removed the row!
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.
the language I am looking is MS Visual Basic.
How can I sort an array and change other arrays accordingly (using an index?)
I was searching, but couldnt find any stuff on that. Any help is greatly appreciated!!!
e.g. Sort array BirthArray and change the order of Array1 and ID accordingly?
Array1 = 'John', 'Christina','Mary', 'frediric', 'Johnny','billy','mariah'
BirthArray = 1998, 1923, 1983,1982,1924,1923,1954
ID = 12312321, 1231231209, 123123, 234324, 23423, 2234234,932423
Dim Array() As String
Dim BirthArray() As Integer
Dim ID() As Integer
Thanks a lot!
You should make a class to hold the values, put a collection of the classes into a List, then sort the the list using a lambda expression:
Public Class Info
Public Property Name As String
Public Property BirthYear As Integer
Public Property ID As Integer
Public Sub New()
End Sub
Public Sub New(sName As String, wBirthYear As Integer, wID As Integer)
Me.New
Me.Name = sName
Me.BirthYear = wBirthYear
Me.ID = wID
End Sub
End Class
Public Sub DoSort()
Dim cRecords As New System.Generic.List(Of Info)
cRecords.Add(New Info('John', 1998, 12312321)
' ToDo: Add more records
cRecords.Sort(
Function (ByVal oItem1 As Info, ByVal oItem2 As Info)
Return oItem2.BirthYear.CompareTo(oItem1.BirthYear)
End Function)
End Sub
The proposed soluton below (based on your VBA tag).
creates a 2D array from 3 single arrays (as suggested by Jesse)
uses Redim Preserve to add a fourth dataset "NewData" to a 2D array "ArrayMaster"
creates a temporary worksheet, dumps "ArrayMaster" to it, sorts by "Newdata" (ascending order) to create a sorted array, "ArrayMaster2"
deletes the working sheet
Excel is very efficient at sorting, so this method provided an easy and quick way for a sort (or multi level sort)
You could use a bubble sort technique if Excel wasn't available for the sheet dump/sort
Option Base 1
Sub ComboArray()
Dim ws As Worksheet
Dim Array1()
Dim Birthday()
Dim ID()
Dim NewData()
Dim ArrayMaster()
Dim ArrayMaster2()
Dim lngRow As Long
Dim lngCalc As Long
Dim lngCheck As Long
Birthday = Array(1998, 1923, 1983, 1982, 1924, 1923, 1954)
Array1 = Array("John", "Christina", "Mary", "frediric", "Johnny", "billy", "mariah")
ID = Array(12312321, 1231231209, 123123, 234324, 23423, 2234234, 932423)
ReDim ArrayMaster(1 To UBound(Array1, 1), 1 To 3)
'Create 2D MasterArray
For lngRow = 1 To UBound(Array1, 1)
ArrayMaster(lngRow, 1) = Array1(lngRow)
ArrayMaster(lngRow, 2) = Birthday(lngRow)
ArrayMaster(lngRow, 3) = ID(lngRow)
Next
NewData = Array(1, 3, 5, 7, 2, 4, 6)
'Check if new field is longer than overall array
If UBound(NewData, 1) > UBound(ArrayMaster, 1) Then
lngCheck = MsgBox("New field exceeds current array size, proceeding will drop off excess records" & vbNewLine & "(Press Cancel to end code)", vbOKCancel, "Do you want to proceed?")
If lngCheck = vbCancel Then Exit Sub
End If
'Add NewData field
ReDim Preserve ArrayMaster(UBound(ArrayMaster, 1), UBound(ArrayMaster, 2) + 1)
For lngRow = 1 To UBound(NewData, 1)
ArrayMaster(lngRow, UBound(ArrayMaster, 2)) = NewData(lngRow)
Next
With Application
.ScreenUpdating = False
.DisplayAlerts = False
lngCalc = .Calculation
End With
'Create working sheet, dump MasterArray and sort by Newdata (position 4 = cell D1)
Set ws = Worksheets.Add
ws.[a1].Resize(UBound(ArrayMaster, 1), UBound(ArrayMaster, 2)).Value2 = ArrayMaster
ws.UsedRange.Sort ws.[d1], xlAscending
'Create our sorted array MasterArray2, now with NewData(1,2,3,4,5,6,7)
ArrayMaster2 = ws.[a1].Resize(UBound(ArrayMaster, 1), UBound(ArrayMaster, 2)).Value2
ws.Delete
'cleanup working sheet
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = lngCalc
End With
End Sub