I have an Excel spreadsheet devoted to monitoring flags and other variables on a device and they are displayed as follows and are dynamically updated:
Flag name TimeStamp Value
SomeFlag 05:45:12 0
SomeOther 08:22:23 1
Another 08:22:23 0
I have another spreadsheet where I provide an overview of all the devices being monitored. On this spreadsheet, I would like to only display flags that have the value of 1 on the devoted spreadsheets. So for the example above, it would look as follows:
Voltage 09:22:45 230V
Current 09:22:45 15A
Flags: SomeOther 1
If more flags were to become 1, they must be added dynamically. For example, if the Another flag becomes 1, the overview would look as follows:
Voltage 09:22:46 230V
Current 09:22:46 15A
Flags: SomeOther 1
Another 1
Can someone assist me? I know how to use VBA, but I need some guidance in getting started with this.
The below will read the data into an array
Sub t()
Dim arr()
ReDim arr(1)
i = 0
With ActiveSheet
lastrow = .Range("A2").End(xlDown).Row
For Each cell In Range("A2:A" & lastrow)
If cell.Offset(0, 2).Value = 1 Then
arr(i) = cell.Value
arr(i + 1) = cell.Offset(0, 2).Value
ReDim Preserve arr(UBound(arr) + 2)
i = i + 2
End If
Next
End With
For i = 0 To UBound(arr()) - 2 Step 2
Debug.Print arr(i) & ":" & arr(i + 1)
'change debug.print to the range/sheet etc of where you would like the output to start
'may need to clean output range first
Next
End Sub
the output is currently only outputting to the immediate window so that will need to be changed but should be enough to get you going. Remember to step 2 when outputting array as you are putting 2 values per iteration
Related
I am working on developing a system health check tool to validate that 4 different systems are in sync. To do that, I need to create a sample dataset of random N number of records for every unique key/combination from a main data set everyday. All 4 systems will be checked for records from this sample dataset and any differences will be highlighted using conditional formatting.
I am having trouble figuring out how to extract the sample dataset from the main dataset with the criteria mentioned above.
For Example, I have a report that has 700 rows. Each unique combination (concatenation to create a key) of the 6 fields [Client-Contractor-Distribution Center-Service Level-Alert Value-Status] has 100 records. This part will be dynamic. There could be any number of unique combinations and any number of records per combination. Image below for reference. Only the groups are shown here as I cannot paste 700 records in the question. There are 7 unique groups with 100 records each.
There are some questions in the comments for which I am giving the clarifications below:
-Combination/Group = Basically a key created with concatenation of the focus columns to recognize/define a category the records may belong to. As example concating First Name & Last Name to create a unique identity of a person.
All records will be on a single sheet. It is a report downloaded from a system.
Sequence of the records of each grouping: All records of a particular group will not be bunched together. All records are dumped from the system on the report. We are creating the group/key by concating the focus columns.
Let's say I want 5 random records for each of the 7 GroupKeys. Essentially, I need a way to get 35 records that are randomly selected, 5 per unique combination.
A sample of the desired output is shown below.
I have tried using RAND() and RANDBETWEEN() formulas. I do get random records. But the problem is that I cannot ensure that I get 5 records per combination and sometimes duplicate records are returned as well. I am open to any method (VBA/Formulas) to achieve this.
This is a very complex problem for someone like me who is only a novice/beginner at VBA at most.
Please, test the next code. It needs a reference to 'Microsoft Scripting Runtime':
Sub RandomRecPerGroup()
Dim sh As Worksheet, shRet As Worksheet, lastR As Long, dict As New Scripting.Dictionary
Dim arr, arrIt, i As Long, j As Long, f As Long, k As Long, count As Long, arrFin
Set sh = ActiveSheet 'use here the sheet you need
Set shRet = sh.Next 'use here the sheet you need (for testing reason, the next against the active one)
shRet.Range("G1").EntireColumn.NumberFormat = "#" 'format the column to keep 'Reference number' as text
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
arr = sh.Range("A2:G" & lastR).Value ' place the range in an array for faster iteration
ReDim arrFin(1 To 5, 1 To 7): k = 1 'reDim the array to keep each group
For i = 1 To UBound(arr) 'iterate between the array elements:
'create a dictionary key if not already existing, with the number of the row as item:
If Not dict.Exists(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) Then
dict.Add arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6), i
Else 'adding the number of row, separated by "|"
dict(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) = _
dict(arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4) & arr(i, 5) & arr(i, 6)) & "|" & i
End If
Next i
Dim rndNo As Long 'a variable to receive the random number
For i = 0 To dict.count - 1 'iterate between the dictionary elements:
arrIt = Split(dict.items(i), "|"): ' split the item by "|" to obtain the same group existing rows
For k = 1 To 5 'iterate to extract the 5 necessary sample rows of each group
Randomize 'initialize the random numbers generation
If UBound(arrIt) = -1 Then Exit For 'for the case of less than 5 rows per group
rndNo = CLng(UBound(arrIt) * Rnd()) 'give a value to the variable keeping the random numbers
For f = 1 To 7 'iterating to place in the array all 7 columns value
arrFin(k, f) = arr(arrIt(rndNo), f)
Next f
arrIt = Filter(arrIt, arrIt(rndNo), False) 'eliminate the element just placed in an array, to avoid doubling
Next k
lastR = shRet.Range("A" & sh.rows.count).End(xlUp).row + 1 'last empty row of the sheet where the result is returned
shRet.Range("A" & lastR).Resize(5, 7).Value = arrFin 'drop the array content
Next i
MsgBox "Ready..."
End Sub
The code may work without the mentioned reference (using labe binding), but I think it should be good to benefit of intellisense suggestions. If it looks complicated to create it, please (firstly) run the next code which will add it automatically:
Sub addScrRunTimeRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
If err.Number = 32813 Then
err.Clear: On Error GoTo 0
MsgBox "The reference already exists...": Exit Sub
Else
On Error GoTo 0
MsgBox """Microsoft Scripting Runtime"" reference added successfully..."
End If
End Sub
Saving the workbook will keep the reference. So, no need to run the code again...
So basically you have 700 possibilities, and you want to get 5 random values out of them, while you are sure that you don't have duplicates?
There are, basically, two ways to do this:
You make a resulting collection of random values, you use the random generator to generate numbers from 1 to 700, but before adding them to your collection, you verify if they are already present in your collection. Something like (pseudo-code):
Dim col_Result as Collection
Dim finished as Boolean = False;
Dim r as integer;
while (not finished){
r = ConvertToInt(Random(700)) + 1;
if not(col_Result.Contains(r))
then col_Result.Add(r);
finished = (col_Result.Count == 5);
}
You make a collection of all numbers from 1 to 700, and 5 times you retrieve a random value out of it, while subtracting that value from the collection. Something like (pseudo-code again):
Dim col_Values as Collection = (1, 2, ..., 700);
Dim col_Result as Collection;
Dim r as integer;
for (int i = 0; i < 5; i++){
r = ConvertToInt(Random(700));
col_Result.Add(r);
col_Values.Subtract(r);
}
When using this last approach, it is vital that subtracting a value from the collection shifts the other values: (1,2,3,4,5).Subtract(2) yields (1,3,4,5).
I have an Access function built to export a query to Excel. There are spaces for 15 results. Not all of them are used though, so I'd like to delete the blank columns.
I've been trying to search Lrow + 1 for "0.000" and then deleting the entire column, but it isn't working. 0.000 is a formula but I am using .Value method so that shouldn't be the problem, right?
Here's the code I tried to write (but failed miserably):
For Each Cel In wks.Range("C" & Lrow + 1, "V" & Lrow + 1)
If Cel.Value = "0.000" Then
Cel.EntireColumn.Delete
Cel.Offset(0, 1).EntireColumn.Delete
End If
Next Cel
As in the picture, there are 2 results shown. This is what I would like to happen: Search lrow + 1 (the row with 0.000), delete those columns along with the column next to it.
Any help would be appreciated.
A few issues here:
The range reference is wrong as Big Ben pointed out
The comparison is (probably) wrong. I'm guessing the call values are numbers, not strings that look like numbers. So comparing 0 to "0.000" will fail. Use = 0 or if you are worried about small not quite 0 numbers use Absolute value <= 0.0005
The delete logic is flawed, it won't delete the columns you think
.
Set rng = wks.Range("C" & Lrow + 1 & ":V" & Lrow + 1)
For i = rng.Columns.Count To 1 Step -1
If rng.Cells(1, i).HasFormula Then
If Abs(rng.Cells(1, i)) <= 0.0005 Then
Rng.Cells(1, i).Resize(1, 2).EntireColumn.Delete
End If
End If
Next
Don't forget to use Option Explicit and declare all variables
There is a question similar to this one but it does not meet the specifications here.
I have a MultiSelect ListBox and a table which represents an AdvancedFilter criteria.
I want to populate the column "Level" of this table with all the values selected from the ListBox, every value should be in a separate row (OR condition for an AdvancedFilter).
The results I am seeking :
If no item is selected, it should remove the rows added in the table and only populate "<>0".
The code I have written so far does the tricks shown in the 2 first images but and when I deselect all the items it does not work anymore:
Private Sub ListBox1_LostFocus()
Dim aArray() As Single
ReDim aArray(1 To 1) As Single
With ListBox1
For I = 0 To .ListCount - 1
If .Selected(I) Then
aArray(UBound(aArray)) = .List(I)
ReDim Preserve aArray(1 To UBound(aArray) + 1) As Single
End If
Next I
End With
Range(Cells(3, "S"), Cells(UBound(aArray) - 1, "S"))= Application.Transpose(aArray)
End Sub
Has someone already dealt with this issue? Any help would be much appreciated! Thank you so much!
I think this will do what you want. As per my comment about preloading with "<>0" - that's not possible because your array is a Single. So you need to trap it. Also, I tweaked your range to write to as in my mock up I kept getting a zero on the end if 1 or more were selected.
Dim aArray() As Single
ReDim aArray(1 To 1) As Single
With ListBox1
For I = 0 To .ListCount - 1
If .Selected(I) Then
aArray(UBound(aArray)) = .List(I)
ReDim Preserve aArray(1 To UBound(aArray) + 1) As Single
End If
Next I
End With
Range("S3:S10").ClearContents ' change this range to suit
If UBound(aArray) = 1 Then
Range("S3") = "<>0"
Else
Range(Cells(3, "S"), Cells(3 + UBound(aArray) - 2, "S")) = Application.Transpose(aArray)
End If
It looks complicated, but it does the job neatly.
Private Sub ListBox1_LostFocus()
'
'is called when you finish selecting items from the ListBox
'
Dim aArray() As Single
ReDim aArray(1 To 1) As Single
'fetch selected items of listbox into aArray
With ListBox1
For I = 0 To .ListCount - 1
If .Selected(I) Then
aArray(UBound(aArray)) = .List(I)
ReDim Preserve aArray(1 To UBound(aArray) + 1) As Single
End If
Next I
End With
'clear old items in the advanced filter's condition table to replace them with those we fetched
'/!\ if there was more old items than new items, we would need to delete their rows from the table
Range("Condition[Level]").ClearContents
'we need to compare the size of the array with the size of the table so that we don't have extra rows
'(the advanced filter interpretates empty rows as '*' so we absolutely need to get rid of them)
r = UBound(aArray)
n = Range("Condition[#Data]").Rows.count
If UBound(aArray) = 1 Then
Range("Condition[Level]") = "<>0" 'if nothing is selected, fetch every item meaning numeric and non numeric (more powerful than "*")
Range("Condition[Serial]") = "*" 'columns to the left of 'Level' are not automatically replicated in the table (contrary to those on the right which gets previous row's) values so they become empty, that's why we need to fill them with the value we want
Range("Condition[#Data]").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
Else
Range(Cells(3, "S"), Cells(3 + UBound(aArray) - 2, "S")) = Application.Transpose(aArray)
If n > r - 1 Then
[Condition].Rows(r & ":" & n).Select ' r+1 to skip the headers' row
[Condition].Rows(r & ":" & n).Delete 'doing a select before the delete prevents a bug which would delete the entire rows of the sheet
End If
End If
If you have an improvement to my code, i will gladly take it! I am slightly new to VBA, i'm sure there are tons of ways to improve it.
If you have a request similar to this issue, feel free to ask any question.
I have an excel worksheet with a lot of data that needs pruning.
Data is a organized by ID number with multiple rows attached to a given ID. For each unique ID, I need to to keep all rows with certain codes (which are found in column B). I also need to keep the rows immediately above the rows with the "keeper codes," provided such a row exists. If no such row exists, then I need to insert a blank row.*
For a given ID, if no "keeper code" is present, then all rows associated with the ID should be deleted. All rows not associated with a "keeper code" or immediately above a row with a "keeper code" should be deleted.
Probably best explained by screenshot. Data will be sorted by ID number as pictured.
*Inserting a blank row would be nice but if it makes the coding difficult then is not very necessary.
Thanks much!
Try this out,
Sub copyRows()
Dim i As Long, j As Long
Sheets.Add.Name = "newSheet"
Rows(1).Copy Sheets("newSheet").Cells(1, 1)
j = Sheets("newSheet").Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If InStr(Cells(i, 2), "Keep") > 0 And Cells(i, 1) = Cells(i - 1, 1) Then
Rows(i - 1).Copy Sheets("newSheet").Cells(j, 1)
Rows(i).Copy Sheets("newSheet").Cells(j + 1, 1)
ElseIf InStr(Cells(i, 2), "Keep") > 0 Then
Rows(i).Copy Sheets("newSheet").Cells(j, 1)
End If
j = Sheets("newSheet").Cells(Rows.Count, 1).End(xlUp).Row + 1
Next i
End Sub
If inserting empty rows is necessary you may have to work on that logic.
This macro creates a new sheet with the output.
I have a data set with Names and Addresses in an Excel file in following format.
Name1
134/47/1,
adrs1, adr2, country
Name2
adrs1, adrs2, country
Name3
107/c,
adrs3, adrs3, country
etc…
I want to split these data into multiple rows in following format
Name1
134/47/1,
adrs1,
adrs2,
country
Name2
No 134/63,
adrs1,
adrs2,
country
etc…
I tried following but it worked for one row cell only.
Sub tst()
Dim X As Variant
X = Split(Range("A1").Value, ",")
Range("A1").Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End Sub
The following macro might help you. You would have to select the very last cell in your table containing a multipart address. When you start the macro it will then work its way up to the top and insert address lines where needed (only in the current column) and then exit.
Option Base 1
Sub trnsfrm()
Dim i%, n%, ret(3, 1)
Set r = Selection
Do
a = Split(r, ",")
ret(1, 1) = Trim(a(0))
ret(2, 1) = Trim(a(1))
ret(3, 1) = Trim(a(2))
r.Range([a2], [a3]).Insert Shift:=xlDown
r.Range([a1], [a3]) = ret
If r.Row <= 4 Then Exit Do
Set r = r.Offset(-4)
Loop
End Sub
If you want to insert lines across the whole table you should replace the line (10)
r.Range([a2], [a3]).Insert Shift:=xlDown
by
r.Range([a2], [a3]).EntireRow.Insert Shift:=xlDown
Assumptions / Warning
Since the macro will actually change your current table and 'undo' does not work with macros you should definitely save everything before you try it.
The macro assumes that each address block consists of exactly 4 lines. If there are fewer or more lines to an address the maro will get out of sync and will very likely output garbage or halt.
I'm not sure whether your sample data had trailing commas on single values as a typo or if that is what accurately represents your data but that should be accounted for. A rogue comma as a suffix will create an extra element to the variant array thereby throwing off dimensions created by referencing the UBound function.
Sub split_from_below_space()
Dim rw As Long, v As Long, vVALs As Variant
With Worksheets("Sheet1") 'set this worksheet reference properly!
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
.Cells(rw, 1) = Trim(.Cells(rw, 1).Value2)
If CBool(InStr(1, .Cells(rw, 1).Value2, Chr(44) & Chr(32))) Then
vVALs = Split(.Cells(rw, 1).Value2, Chr(44) & Chr(32))
.Cells(rw + 1, 1).Resize(UBound(vVALs), 1).EntireRow.Insert
.Cells(rw, 1).Resize(UBound(vVALs) + 1, 1) = _
Application.Transpose(vVALs)
For v = UBound(vVALs) - 1 To LBound(vVALs) Step -1
.Cells(rw, 1).Offset(v, 0) = _
Trim(.Cells(rw, 1).Offset(v, 0).Value2) & Chr(44)
Next v
End If
Next rw
End With
End Sub
You will need to insert rows to accommodate the data and that method is almost always (as in this case) better performed by working from the bottom to the top.