I am working on some data from which I want to extract unique values from a column and storing them in an array and later using it for other calculations.
Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([E1], Cells(Rows.Count, "E").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range("K1:K" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub
The Data set is found here.
Now I want the code to take the input using an input box which column to search([E1] here) for unique values and where the output is stored ("K1:K" here).
Add the InputBox code with a variable to hold its value:
Dim col As String
Dim output_col As String
col = InputBox("Type the column letter to search in", "Data Input")
output_col = InputBox("Type the column letter to write results to", "Data Input")
And add some logic, e.g., if the column letter length is not 0, process.
Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Dim col As String
Dim output_col As String
col = InputBox("Type the column letter to search in", "Data Input")
output_col = InputBox("Type the column letter to write results to", "Data Input")
If Len(col) > 0 And Len(output_col) > 0 Then
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range(col & CStr(1), Cells(Rows.Count, col).End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range(output_col & CStr(1) & ":" & output_col & objDict.Count) = Application.Transpose(objDict.keys)
End If
End Sub
Related
I am working with a schedule, that I have imported and formatted into my workbook.
I am wanting this to populate Phase in the upper listbox and then when a phase is selected the sub-task associated with those phases are displayed in the bottom listbox.
I want to use an array but I seem to be having problems when the columns are not next to each other or there are "gaps" with the blank cells.
My first attempt using assigning the Array to the currentregion worked but brought all columns and fields in. Listbox1 should contain (ID, PHASE NAME, DURATION, START DATE, FINISH DATE) List box 2 should when a Phase is selected contain the subtasks if any from the column to the right, listed before the next next Phase name. (ID, SUB-TASK NAME, DURATION, START DATE, FINISH DATE)
(See picture)
I have code but its more me trouble-shooting than an actual semi working script.
Dim shT As Worksheet
Dim schnumrng1 As Range
Dim schnumrng2 As Range
Dim schnumrng3 As Range
Dim schnumrng4 As Range
Dim schnumrng5 As Range
Dim schpersonrng As Range
Dim schphaserng As Range
Dim schlistrng As Range
Dim maxschnum
Dim schstatus
Dim schperson
Dim schlistnum
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim rng As Range
Dim cl As Range
Dim lc
'allowevents = True
''Set Screen parameters
'Application.ScreenUpdating = False
'Application.EnableEvents = False
'
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
Set schnumrng = Range("B5", "B" & maxschnum)
'Set Ranges for the list box
Set schnumrng1 = Range("A5", "A" & maxschnum)
Set schnumrng2 = Range("B5", "B" & maxschnum)
Set schnumrng3 = Range("D5", "D" & maxschnum)
Set schnumrng4 = Range("E5", "E" & maxschnum)
Set schnumrng5 = Range("F5", "F" & maxschnum)
'This is static and not moving to the next line in my for statement / switched to named ranges and errors
Set rng = schnumrng1, schnumrng2, schnumrng3, schnumrng4, schnumrng5
'Set rng = Range("A5,B5,D5,E5,F5")
i = 1
j = 1
For Each lc In schnumrng
If lc <> vbNullString Then
For Each cl In rng
ReDim Preserve Ar(1, 1 To i)
Ar(j, i) = cl.Value
i = i + 1
Next cl
Else
End If
j = j + 1
Next lc
With ScheduleForm.SchMainTasklt
.ColumnCount = i - 1
.ColumnWidths = "50;150;50;50;50"
.List = Ar
End With
My problem then is two fold, trying to use the dynamic ranges or another tool Index? collection? to populate the 1st list box. 2. How to deal with blanks and noncontiguous columns when data is not separated for organization purposes.
I don't know if I figured out your intentions well.
First, only the data in column b, not empty cells, is extracted from listbox1.
Second, when listbox1 is selected, data related to listbox2 is collected through the selected listbox value.
Module Code
Place this code in the module. This is because global variables must be used.
Public vDB As Variant
Public Dic As Object 'Dictionary
Sub test()
Dim shT As Worksheet
Dim maxschnum As Long
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim vC() As Variant
Dim cnt As Integer, n As Integer
Dim c As Integer
Dim s As String, s2 As String
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set Dic = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
With shT
vDB = .Range("a5", .Range("f" & maxschnum))
End With
'vC is data colum A,B,D,E,F
vC = Array(1, 2, 4, 5, 6)
s2 = vDB(2, 2)
For i = 2 To UBound(vDB, 1)
s = vDB(i, 2) 'column B
If s = "" Then
n = n + 1
Else
If Dic.Exists(s) Then
Else
If i > 2 Then
Dic(s2) = Dic(s2) & "," & n
End If
Dic.Add s, i
s2 = s
cnt = cnt + 1
ReDim Preserve Ar(1 To 5, 1 To cnt)
For c = 0 To UBound(vC)
Ar(c + 1, cnt) = vDB(i, vC(c))
Next c
End If
n = 0
End If
Next i
Dic(s2) = Dic(s2) & "," & n
' Records information about the data in a dictionary.
' Dic is "phase neme" is Key, Item is "2,4"
' example for KICkOFF
' dic key is "KICKOFF", Item is "5,4"
' 5 is KICOFF's row number in array vDB
' 4 is the number of blank cells related to kickoff.
With ScheduleForm.SchMainTasklt
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
'.List = Ar
.Column = Ar 'In the state that the array has been converted to row column, you can use listbox.column.
End With
End Sub
Form Code
Private Sub UserForm_Initialize()
Call test
End Sub
Private Sub SchMainTasklt_Click()
Dim s As String, sItem As String
Dim arr As Variant, vC As Variant
Dim vR() As Variant
Dim st As Long, ed As Long
Dim iLast As Long, iFirst As Long
Dim i As Long, n As Integer
Dim j As Integer
vC = Array(1, 3, 4, 5, 6) 'data colums A,C,D,E,F
s = SchMainTasklt.Value
'MsgBox s
sItem = Dic(s)
arr = Split(sItem, ",")
st = Val(arr(0))
ed = Val(arr(1))
iFirst = st + 1
iLast = st + ed
If ed = 0 Then
MsgBox "no data!!"
Exit Sub
End If
For i = iFirst To iLast
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
For j = 0 To UBound(vC)
vR(j + 1, n) = vDB(i, vC(j))
Next j
Next i
With ListBox2
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
.Column = vR
End With
End Sub
Result Image
When you click the "KICKOFF" , Show kickoff related data in listbox2.
The following code reads lines from a csv file and reformats row headings. I hope I can articulate this, but I'd like to format cells to two decimals in rows below headings in which the vct_FEMAP_Results() function returns a value.
Example:
ID "CSys ID" "Set ID" Plate Top VM Stress Plate Bot VM Stress
------ ----------- ---------- ----------------------- ----------------------
4591 0 20 229.9488 244.8103
4592 0 20 323.5026 315.1129
I'm trying to format the cells containing the decimals without affecting the data in column headings ID, CSys ID, or Set ID. The code below formats all columns to 2 decimals. Not sure why.
Sub cmdOpen_Click()
Dim wrdArray() As String, txtstrm As TextStream, line As String
Dim wrd As Variant, myWrd As String
Dim col As Long, colCount As Long
Dim count As Long
Dim row As Long, temp As Long
Dim str As String, regex As RegExp
Dim matches As MatchCollection, lineMatch As match, wrdMatch As match
Dim i As Long, j As Long, x As Long
Dim strPath As String, strLine As String
Set regex = New RegExp
regex.Pattern = "\d+"
regex.Global = True
'Remove Filters and Add Custom Filters
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Text Files", "*.txt")
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Dat Files", "*.dat")
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Comma Delimited Files", "*.csv")
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
End If
'------------------------------------------------------------
If strPath <> "" Then
Set txtstrm = FSO.OpenTextFile(strPath)
Else
Exit Sub
End If
row = 1
Do Until txtstrm.AtEndOfStream
line = txtstrm.ReadLine
x = 1
col = 1
count = 0
wrdArray() = Split(line, ",")
For Each wrd In wrdArray()
count = count + 1
myWrd = wrd
ActiveSheet.Cells(row, col) = wrd
col = col + 1
Next wrd
If (row = 1) Then
For i = 0 To count - 1
Set matches = regex.Execute(wrdArray(i))
For Each wrdMatch In matches
If wrdMatch Then
ActiveSheet.Cells(1, i + 1) = vct_FEMAP_Results(wrdMatch.Value)
x = x + 1
End If
Next
Next i
End If
row = row + 1
Loop
txtstrm.Close
For i = 1 To row - 1
For j = x To col - 1
ActiveSheet.Cells(i, j).NumberFormat = "0.00"
Next j
Next i
End Sub
Your code is formatting all your columns because you are looping through the columns with this bit:
For i = 1 To row - 1
For j = x To col - 1
ActiveSheet.Cells(i, j).NumberFormat = "0.00"
Next j
Next i
If you already know which columns need to be formatted, just do it like this:
ActiveSheet.Range("d:d, e:e").EntireColumn.NumberFormat = "0.00"
That will reformat only columns D and E, as per your sample data. Change the d's and e's if you need other columns.
I actually prefer to avoid using "ActiveSheet" and always reference the specific worksheet explicitly, so I'm always sure which worksheet my code is targeting. Whereas, when you use ActiveSheet(or cell or workbook) the active sheet can change, sometimes in unexpected ways.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
ws.Range("d:d, e:e").EntireColumn.NumberFormat = "0.00"
I hope that helps!
transactions sheet
ID1 Name Amount ID2
123 A 1 0;124;0
456 B 2 124;0;0
789 C 3 456;0;0
transactions sheet (Expected Result)
ID1 Name Amount ID2 Summary
123 A 1 0;124;0 124
456 B 2 124;0;0 456
789 C 3 456;0;0
I have tried text to columns but I am unsure on how to ignore all the 0's and only display the value if its >0 in column D. I am new to vba so would appreciate some advice on this so I can learn.
Code:
Sub SplitRange()
Dim cell As Range
Dim str As Variant 'string array
Dim r As Integer
For Each cel In ActiveSheet.UsedRange
If InStr(cell.Value, ";") > 0 Then 'split
str = Split(cell.Value, ";")
For r = LBound(str) To UBound(str)
cel.Offset(r).Value = Trim(str(r))
If r < UBound(str) Then cell.Offset(r + 1).EntireRow.Insert
Next r
End If
Next cell
End Sub
At first we should not loop through all used cells but only the row where these ID2 are that we need, which is a lot faster.
The easiest way would be just to remove all ;0 and 0; then only the value remains. The following will work if there is always only one real value that is not 0 e.g 0;124;0.
Public Sub FindValueRangeInColumn()
Const Col As Long = 4 'the column where the ID2 is in
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row 'find last used row in column
Dim iRow As Long
For iRow = 2 To lRow 'loop throug rows from 2 to last used row
Dim strSource As String
strSource = ws.Cells(iRow, Col) 'read value
strSource = Replace(ws.Cells(iRow, Col), ";0", "") 'remove all ;0
If Left$(strSource, 2) = "0;" Then strSource = Right$(strSource, Len(strSource) - 2) 'remove 0; from the beginnning
ws.Cells(iRow, Col + 1).Value = strSource 'write value
Next iRow
End Sub
If there can be more than 1 non-zero value like 0;124;0;222;0;0;144 then replace
ws.Cells(iRow, Col + 1).Value = strSource 'write value
with a splitting alternative …
If InStr(1, strSource, ";") > 1 Then
Dim SplitValues As Variant
SplitValues = Split(strSource, ";")
Dim iValue As Long
For iValue = LBound(SplitValues) To UBound(SplitValues)
ws.Cells(iRow, Col + 1 + iValue).Value = SplitValues(iValue) 'write value
Next iValue
Else
ws.Cells(iRow, Col + 1).Value = strSource 'write value
End If
Morning,
What you need here is to split the entry into an array and then check the values of the array as you loop the array:
Sub SplitString()
Dim TempArray() As String
Dim i as Integer
Dim j As Integer
For i = 1 To 10
TempArray = Split(Worksheets("Sheet1").Cells(i,4).Value,";")
For j = 0 to UBound(TempArray)
If CDbl(TempArray(j)) <> 0 Then
[Output value]
End if
Next j
Next i
End Sub
Create a more useful loop than 1 = 1 to 10 but you get the idea...
Note in the above:
- The CDbl is to ensure that the check reads it as a number and not a text string.
So, you want to concatenate non-0 values into a string, then put that in the next cell?
Sub SplitRange()
Dim workcell As Range
Dim str() As String 'string array
Dim r As Long 'VBA automatically stores Integers as Longs, so there is no Memory saved by not using Long
Dim output As String
output = ";" 'Start with a single delimiter
For Each workcell In Intersect(ActiveSheet.UsedRange,ActiveSheet.Columns(4)) 'Go down the cells in Column D
If InStr(workcell.Value, ";") > 0 Then 'split
str = Split(workcell.Value,";")
For r = LBound(str) To UBound(str)
If inStr(output, ";" & Trim(str(r)) & ";") < 1 Then 'If number is not already in output
output = output & Trim(str(r)) & ";" 'Add the number and ";" to the end of the string
End If
Next r
Erase str 'Tidy up array, ready to recycle
End If
Next workcell
'We now have a unique list of all items, starting/ending/delimited with ";"
output = Replace(output,";0;",";") 'Remove the item ";0;" if it exists
If Len(output) > 2 Then 'output contains at least 1 non-zero number
output= Mid(output,2,len(output)-2) 'Remove ";" from the start and end
str = Split(output,";") 'Split the list of unique values into an array
For r = lbound(str) To ubound(str)
ActiveSheet.Cells(r+2-lbound(str),5).Value = str(r) 'List the values in column 5, starting from row 2
Next r
Erase str 'Tidy up array
End If
End Sub
To remove "0"s from a single row as an Excel formula, try this:
=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE("|;" & A1 & ";|", ";0;",";"),";|",""),"|;","")
From the inside-out:
SUBSTITUTE("|;" & A1 & ";|", ";0;",";") Sandwich our values in wrappers ("|;0;240;0;|") and replace any ";0;" with ";" ("|;240;|")
.
SUBSTITUTE(PREV,";|","") Remove ";|" ("|;240")
.
SUBSTITUTE(PREV,"|;","") Remove "|;" ("240")
I have an excel table that looks like this:
Row Name
1 uniqueName001_vid1.mpg
2 uniqueName001.mpg
3 uniqueName002_vid1.mpg
4 uniqueName002_vid2.mpg
5 uniqueName002.mpg
I am trying to figure out how to identify and flag(give a unique ID) sets within the table that contain the same uniqueName. For instance Row's 1 and 2 would be one set and Row's 3, 4, and 5 would be another set.
My ideal result is this:
Row Name UID
1 uniqueName001_vid1.mpg SET1
2 uniqueName001.mpg SET1
3 uniqueName002_vid1.mpg SET2
4 uniqueName002_vid2.mpg SET2
5 uniqueName002.mpg SET2
I can run a SQL query in excel if that is better option than excel formula's too.
Any suggestions are greatly appreciated!
If all starts with uniqueNameXXX than it is easy
Row Name UniqueName Unique# UID
1 uniqueName001_vid1.mpg =LEFT(F4;13) =IF(G3<>G4;H3+1;H3) ="UID"&H4
If not, than you should define how to get uniqueName
You can use VBA for that task.
I made a little tool for you. Take care of the editable part
under the declarations.
This tool listens on numbers - means, I expect your pattern to be always the same as you wrote in your question.
Tell me if this helped:
Sub ExtractIdFromString()
Dim strYourColumn As String
Dim intYourStartRow As Integer
Dim intYourLengthOfId As Integer
Dim strYourSetColumn As String
Dim strYourPrefix As String
Dim strString As String
Dim intStringLength As Integer
Dim intStringDigitPosition As Integer
Dim intParserPosition As Integer
Dim strParser As String
Dim i As Integer
Dim strUniqueString As String
Dim rngCell As Range
Dim rngSetCell As Range
Dim strIndex As String
Dim lngCounter As Long
''''editable values''''
strYourColumn = "B" 'Your name column, must be alphabethical
intYourStartRow = 1 'Startrow of your block, must not be 0
intYourLengthOfId = 3 'The amount of digits in your ID, must be > 1
strYourSetColumn = "C" 'The column, where the ID will be inserted, must be numerical (use A = 1, Z = 26)
strYourPrefix = "SET" 'Prefix of your set's ID
''''end of editable values''''
'Set the format of the ID column to text
Range(strYourColumn & ":" & strYourColumn).NumberFormat = "#"
'traverse through the names column
For Each rngCell In Range(strYourColumn & ":" & strYourColumn)
'initialize / reset parser
intParserPosition = 1
'get the actual string to value
strString = rngCell.Value
'End loop on empty cell
If strString = "" Then
GoTo massRename
End If
'get the string's length
intStringLength = Len(strString)
'parse through the string
For intStringDigitPosition = 1 To intStringLength Step 1
'end loop if the string is parsed without a result
If intParserPosition > intStringLength Then
Exit For
End If
'get single digit of the string
strParser = Mid(strString, intParserPosition, 1)
'listen on numbers
If IsNumeric(strParser) Then
'traverse through the expected ID slots
For i = intParserPosition To intParserPosition + intYourLengthOfId - 1 Step 1
'listen for non numerical chars in the expected ID
If Not IsNumeric(Mid(strString, i, 1)) Then
'allow your titles to include numbers
GoTo SkipSingleNumerics
End If
Next
'get the unique prototype of the string
strUniqueString = Mid(strString, 1, intParserPosition + intYourLengthOfId - 1)
'write the unique name in a specified column
Range(strYourSetColumn & rngCell.Row).Value = strUniqueString
End If
'Skip numbers in the string, that dont dont match the ID pattern (optional)
SkipSingleNumerics:
'traverse trough the word
intParserPosition = intParserPosition + 1
Next
Next
'Rename and index equal values
massRename:
lngCounter = 1
'traverse through the set list
For Each rngSetCell In Range(strYourSetColumn & ":" & strYourSetColumn)
'end condition
If rngSetCell.Value = "" Then
Exit For
End If
'store value in variable to save it from overwriting
strIndex = rngSetCell.Value
'start another traversal instance
For Each rngCell In Range(strYourSetColumn & ":" & strYourSetColumn)
'end condition
If rngCell.Value = "" Then
Exit For
End If
'listen if both instances match
If strIndex = rngCell.Value Then
'rename the value
rngCell.Value = strYourPrefix & lngCounter
End If
Next
'increase unique counter
lngCounter = lngCounter + 1
Next
End Sub
tested in Excel 2010
I currently have an array which I populate and paste in a sheet named "T1" using a macro. My current macro uses the rowcount function to determine the used rows and pastes the array from the next available row.
The problem I am having is that when I paste this array multiple times, the arrays need to be spaced by a row so that i can differentiate different submissions. This is what I have so far, and I was hoping someone could help me with this:
Sub CopyData()
Dim Truearray() As String
Dim cell As Excel.Range
Dim RowCount1 As Integer
Dim i As Integer
Dim ii As Integer
Dim col As Range
Dim col2 As Range
i = 0
ii = 2
RowCount1 = DHRSheet.UsedRange.Rows.Count
Set col = DHRSheet.Range("I1:I" & RowCount1)
For Each cell In col
If cell.Value = "True" Then
Dim ValueCell As Range
Set ValueCell = Cells(cell.Row, 3)
ReDim Preserve Truearray(i)
Truearray(i) = ValueCell.Value
Dim siblingCell As Range
Set siblingCell = Cells(cell.Row, 2)
Dim Siblingarray() As String
ReDim Preserve Siblingarray(i)
Siblingarray(i) = DHRSheet.Name & "$" & siblingCell.Value
i = i + 1
End If
Next
Dim RowCount2 As Integer
RowCount2 = DataSheet.UsedRange.Rows.Count + 1
For ii = 2 To UBound(Truearray)
DataSheet.Cells(RowCount2 + ii, 2).Value = Truearray(ii)
Next
For ii = 2 To UBound(Siblingarray)
DataSheet.Cells(RowCount2 + ii, 1).Value = Siblingarray(ii)
Next
DataSheet.Columns("A:B").AutoFit
MsgBox ("Data entered has been successfully validated & logged")
End Sub
If you Offset two rows from the bottom cell, you will leave a blank row of separation. You should also consider filling the whole array as base 1 and writing it to DataSheet in one shot.
Sub CopyData2()
Dim rCell As Range
Dim aTrues() As Variant
Dim rRng As Range
Dim lCnt As Long
'Define the range to search
With DHRSheet
Set rRng = .Range(.Cells(1, 9), .Cells(.Rows.Count, 9).End(xlUp))
End With
'resize array to hold all the 'trues'
ReDim aTrues(1 To Application.WorksheetFunction.CountIf(rRng, "True"), 1 To 2)
For Each rCell In rRng.Cells
If rCell.Value = "True" Then
lCnt = lCnt + 1
'store the string from column 2
aTrues(lCnt, 1) = DHRSheet.Name & "$" & rCell.Offset(0, -7).Value
'store the value from column 3
aTrues(lCnt, 2) = rCell.Offset(0, -6).Value
End If
Next rCell
'offset 2 from the bottom row to leave a row of separation
With DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Offset(2, 0)
'write the stored information at one time
.Resize(UBound(aTrues, 1), UBound(aTrues, 2)).Value = aTrues
End With
End Sub