I'm trying to use the MATCH function to determine a row. I have several holes and some of the holes go through numerous parts (ex: hole 1 could go through two parts, but Hole 2, next to it, could go through four parts). The diameters could be different in each layer, and can vary by quite a bit. I need to pull the correct diameter for the layer. My code works up to the line where I try to get j equal to the row number that the next hole is on. I think my problem is with the range. I'd like to use the table header, since the input table size can vary from project to project.
I updated the code to reflect the suggestions in the comment and the research I was able to do to use the table header in the MATCH function. The issue now is that it pulls the row below what I would have anticipated. Using the code on the example table, j , the row that MATCH returns, is 5, which is a row for Hole 3, unless it counts the header row, but I thought that using dataBodyRange would exclude that row. Note that my table begins at cell A5. I think I still have a reference issue.
Private Sub UpdatePitchDia_Click()
'Want to use diameters from the same part
Dim i
Dim j
Dim LastRowIn
Dim Hole_Num
Dim Incoming_Dia
Dim Hole_L
Dim Hole_R
Dim Hole_U
Dim Hole_D
Dim Stack_Up
Dim Stack_Up_L
Dim L_Dia
Dim tbl_In As ListObject
Dim Hole As Range
Set tbl_In = ThisWorkbook.Sheets("Input").ListObjects("tbl_Input")
Set Hole = tbl_In.ListColumns(1).Range
LastRowIn = tbl_In.DataBodyRange.Rows.Count
i = 1
j = 0
For i = 1 To LastRowIn Step 1
Hole_L = [tbl_Input].Cells(i, 4)
If Not IsEmpty(Hole_L) Then 'Not all holes have adjacent holes
'Need to make sure that the part layers are the same
j = WorksheetFunction.Match(Hole_L, Hole, 0)
'MsgBox "Row of Hole Left (" & Hole_L & ") is " & j
Stack_Up = [tbl_Input].Cells(i, 2)
Stack_Up_L = [tbl_Input].Cells(j, 2)
If Stack_Up <> Stack_Up_L Then
j = j + 1
Stack_Up_L = [tbl_Input].Cells(j, 2)
Else: L_Dia = [tbl_Input].Cells(j, 3)
End If
End If
Next
End Sub
Related
I am quite new to VBA and was looking through stackoverflow. I found a neat VBA macro that utilizes Dictionaries and seemed like it could be applied to my problem also. However, after editing the macro I can't seem to make it work like I mean to.
My data is as follows: In column A I have Review numbers, Review topics and Analysis numbers. These follow a structure where Review number is 1st, then 2 rows later there is Review topic and under Review topic can be multiple Analysis numbers but the 1st one is 2 rows below the Review topic. In column B there are details about the reviewed item. I am interested in 3 different ones(height, weight and price). There is sometimes extra details here which is why I use string-matching (InStr). Sometimes there are less details. In general the data does not have a specific enough form to rely on the amount of rows between specific groups of data.
Data looks generally like this: https://imgur.com/a/QcdrMcR
The goal is to move extract the contents of the cells containing Review number, Review topic, Analysis number, Height, Weight and Price. These should be in separate cells on the same row. In case of multiple analysis, the following analysis should be below the row containing the 1st analysis and height, weight and price following this like before. Review number and topic dont need to be duplicated.
In the code I use dictionaries and a whole lotta ElseIfs. As I said, this is largely taken from another post. It works fine if I try to find the 1st analysis detail but when I try to find all 3 it stops working altogether giving me error 424 object required on the 2 last ElseIfs in the 1st loop. Moreover, the part that mostly works (finding the detailA which is height) only works if the searched string is found on the cell one row below the current row. In other words, it only works if the height/detailA is on row i+1
Sub FindData()
Dim datasheet As Worksheet
Dim reportsheet As Worksheet
Dim SearchString As String
Dim SearchString2 As String
Dim i As Integer
Set datasheet = Sheet1
Set reportsheet = Sheet2
Dim chNum As String
Dim chSub As String
Dim analysisNum As String
Dim detailA As String
Dim detailB As String
Dim detailC As String
Dim ReviewCollection As New Dictionary
Dim dictKey1 As Variant
Dim dictKey2 As Variant
Dim dictKey3 As Variant
Dim dictKey4 As Variant
Dim dictKey5 As Variant
Dim dictKey6 As Variant
reportsheet.Range("A1:H200").ClearContents
finalrow = datasheet.Cells(datasheet.Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
SearchString = datasheet.Range("A" & i)
SearchString2 = datasheet.Range("B" & i)
If InStr(1, SearchString, "Review number") Then
chNum = datasheet.Cells(i, 1)
ReviewCollection.Add chNum, New Dictionary 'For review numbers
ElseIf InStr(1, SearchString, "Review topic") Then
chSub = datasheet.Cells(i, 1)
ReviewCollection.Item(chNum).Add chSub, New Dictionary 'For review topics
ElseIf InStr(1, SearchString, "Analysis number") Then
analysisNum = datasheet.Cells(i, 1)
ReviewCollection.Item(chNum).Item(chSub).Add analysisNum, New Dictionary 'For Analysis numbers
ElseIf InStr(1, SearchString2, "Height") Then
detailA = datasheet.Cells(i, 2)
ReviewCollection.Item(chNum).Item(chSub).Item(analysisNum).Add detailA, New Dictionary 'For Analysis detail #1
'ElseIf InStr(1, SearchString2, "Weight") Then
' detailB = datasheet.Cells(i, 2)
' ReviewCollection.Item(chNum).Item(chSub).Item(analysisNum).Item(detailA).Add detailB, New Dictionary 'For Analysis detail #2
'ElseIf InStr(1, SearchString2, "Price") Then
' detailA = datasheet.Cells(i, 2)
' ReviewCollection.Item(chNum).Item(chSub).Item(analysisNum).Item(detailA).Item(detailB).Add detailC, New Dictionary 'For Analysis detail #3
End If
Next i
'Loop to print out the dictionary
i = 1
For Each dictKey1 In ReviewCollection.Keys
reportsheet.Cells(i, 1) = dictKey1 'Review number
If ReviewCollection.Item(dictKey1).Count > 0 Then
For Each dictKey2 In ReviewCollection.Item(dictKey1).Keys
reportsheet.Cells(i, 2) = dictKey2 'Review topic
If ReviewCollection.Item(dictKey1).Item(dictKey2).Count > 0 Then
For Each dictKey3 In ReviewCollection.Item(dictKey1).Item(dictKey2).Keys 'Report Number
reportsheet.Cells(i, 3) = dictKey3
If ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Count > 0 Then
For Each dictKey4 In ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Keys 'Analysis detail #1
reportsheet.Cells(i, 4) = dictKey4
'START of the printing for the problematic area
If ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4).Count > 0 Then
For Each dictKey5 In ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4).Keys 'Analysis detail #2
reportsheet.Cells(i, 5) = dictKey5
If ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4).Item(dictKey5).Count > 0 Then
For Each dictKey6 In ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4).Item(dictKey5).Keys 'Analysis detail #3
reportsheet.Cells(i, 6) = dictKey6
Next dictKey6
Else
i = i + 1 'no reports, so moves down to prevent overwriting change number
End If
Next dictKey5
Else
i = i + 1 'no reports, so moves down to prevent overwriting change number
End If
'END of the problematic area
Next dictKey4
Else
i = i + 1 'no reports, so moves down to prevent overwriting change number
End If
Next dictKey3
Else
i = i + 1 'no reports, so moves down to prevent overwriting change number
End If
Next dictKey2
Else
i = i + 1 'no change subject, so moves down to prevent overwriting change number
End If
Next dictKey1
End Sub
I am also open to any other improvements. My logic seems very heavy but I couldn't get it working even to this degree with any of the other ways (tried using more loops and less if-structures).
I plan on trimming the contents of the cells to only include the numbers but this is a worry for the future. I already have made working excel formulas for this.
I am writing a VBA code that goes through a defined matrix size and filling cells randomly within its limits.
I got the code here from a user on stackoverflow, but after testing it I realized that it does not fit for avoiding duplicate filling, and for instance when filling 5 cells, I could only see 4 cells filled, meaning that the random filling worked on a previously filled cell.
This is the code I'm working with:
Dim lRandom As Long
Dim sCells As String
Dim sRandom As String
Dim rMolecules As Range
Dim i As Integer, j As Integer
Dim lArea As Long
lArea = 400 '20x20
'Populate string of cells that make up the container so they can be chosen at random
For i = 1 To 20
For j = 1 To 20
sCells = sCells & "|" & Cells(i, j).Address
Next j
Next i
sCells = sCells & "|"
'Color the molecules at random
For i = 1 To WorksheetFunction.Min(5, lArea)
Randomize
lRandom = Int(Rnd() * 400) + 1
sRandom = Split(sCells, "|")(lRandom)
Select Case (i = 1)
Case True: Set rMolecules = Range(sRandom)
Case Else: Set rMolecules = Union(rMolecules, Range(Split(sCells, "|")(lRandom)))
End Select
sCells = Replace(sCells, "|" & sRandom & "|", "|")
lArea = lArea - 1
Next i
rMolecules.Interior.ColorIndex = 5
Using this same exact code which works perfectly, WHAT can I insert and WHERE do I do that so that the code would check if a cell is previously already filled with a string or a color?
I feel as though this code I'm looking for should be right before
rMolecules.Interior.ColorIndex = 5
But I'm not sure what to type.
EDIT
From the comments I realized that I should be more specific.
I am trying to randomly fill cells with the blue color (.ColorIndex = 5), but what I need to check first is if the randomizing hadn't marked a cell twice, so that for instance in this case, if I want to mark 5 different cells, it marks only 4 of them because of a duplicate and thus fills only 4 cells with the blue color. I need to avoid that and make it choose another cell to mark/fill.
I'd appreciate your help.
Keep the cells you use in a Collection and remove them as you fill the random cells:
Sub FillRandomCells(targetRange As Range, numberOfCells As Long)
' populate collection of unique cells
Dim c As Range
Dim targetCells As New Collection
' make sure arguments make sense
If numberOfCells > targetRange.Cells.Count Then
Err.Raise vbObjectError, "FillRandomCells()", _
"Number of cells to be changed can not exceed number of cells in range"
End If
For Each c In targetRange.Cells
targetCells.Add c
Next
' now pick random 5
Dim i As Long, randomIndex As Long
Dim upperbound As Long
Dim lowerbound As Long
For i = 1 To numberOfCells
lowerbound = 1 ' collections start with 1
upperbound = targetCells.Count ' changes as we are removing cells we used
randomIndex = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Set c = targetCells(randomIndex)
targetCells.Remove randomIndex ' remove so we don't use it again!
c.Interior.Color = 5 ' do what you need to do here
Next
End Sub
Sub testFillRandomCells()
FillRandomCells ActiveSheet.[a1:t20], 5
FillRandomCells ActiveSheet.[b25:f30], 3
End Sub
EDIT: Changed to make the target range and number of changed cells configurable as arguments to a function. Also added error checking (always do that!).
Why not build a list of random numbers and place in a Scripting.Dictionary, one can use the Dictionary's Exist method to detect duplicates, loop through until you have enough then you can enter your colouring code confident that you have a unique list.
I have a large data set which I need to manipulate and create individual worksheets. Within column B all cells which are coloured Green I would like to make a new worksheet for. Please see screen shot.
For example I would like to create worksheets titled "Shopping" & "Retail". Once the worksheet is created, I would then like to copy all the data between the "worksheet title" (Green Cells) from columns ("B:C") & ("AI:BH") Please see screen shot below for expected output;
The code I have so far is below as you can see it is not complete as I do not know how I would go about extracting data between the "Green Cells".
Sub wrksheetadd()
Dim r As Range
Dim i As Long
Dim LR As Long
Worksheets("RING Phased").Select
LR = Range("B65536").End(xlUp).Row
Set r = Range("B12:B" & (LR))
For i = r.Rows.Count To 1 Step -1
With r.Cells(i, 1)
If .DisplayFormat.Interior.ColorIndex = 35 Then
MsgBox i
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Cells (i,1).Value
Worksheets("RING Phased").Select
End If
End With
Next i
End Sub
Any help around this would be much appreciated.
Sorry for taking a while to get back to this, I've been somewhat busy the last few days, so I haven't had much time to be on StackOverflow.
Anyway, the way I'd go about this would be to store all the found values in an array, and then loop through that array in order to find the distance between them.
The following code works for me, using some very simplified data, but I think the principle is sound:
Option Explicit
Option Base 0
Sub wrksheetadd()
Dim r As Range, c As Range
Dim i As Long: i = 0
Dim cells_with_color() As Range: ReDim cells_with_color(1)
With Worksheets("RING Phased")
' Since it doesn't seem like the first cell you want to copy from is colored, hardcode that location here.
' This also saves us from having to test if the array is empty later.
Set cells_with_color(i) = .Range("B12")
i = i + 1
Set r = Range(.Range("B13"), .Range("B" & .Cells.Rows.Count).End(xlUp))
' Put all the cells with color in the defined range into the array
For Each c In r
If c.DisplayFormat.Interior.ColorIndex = 35 Then
If i > UBound(cells_with_color) Then
ReDim Preserve cells_with_color(UBound(cells_with_color) + 1)
End If
Set cells_with_color(i) = c
i = i + 1
End If
Next
' Loop through the array, and copy from the previous range value to the current one into a new worksheet
' Reset counter first, we start at 1, since the first range-value (0 in the array) is just the start of where we started checking from
' (Hmm, reusing variables may be bad practice >_>)
i = 1
While i <= UBound(cells_with_color)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cells_with_color(i).Value
' Set the range to copy - we could just do this in the copy-statement, but hopefully this makes it slightly easier to read
Set r = .Rows(CStr(cells_with_color(i - 1).Row) + 1 & ":" & CStr(cells_with_color(i).Row))
' Change the destination to whereever you want it on the new sheet. I think it has to be in column one, though, since we copy entire rows.
' If you want to refine it a bit, just change whatever you set r to in the previous statement.
r.Copy Destination:=Worksheets(CStr(cells_with_color(i).Value)).Range("A1")
i = i + 1
Wend
End With
End Sub
It probably lacks some error-checking which ought to be in there, but I'll leave that as an exercise to you to figure out. I believe it is functional. Good luck!
I have a database that has in excess on 200,000 rows. When I was writing a VBA script I had a database of about 20,000 rows in mind so I didn't care whether the database was filtered or not because the VBA script ran quickly. So given the realization that the database is huge and testing the VBA script I was surprised to notice how slowly it ran. So without further to say this is how my code looks like :
Set wsDB = ThisWorkbook.Sheets("DB")
Dim nameIndex As Long: nameIndex = Application.Match(name, wsDB.Rows(1), 0)
Dim formula As String
formula = "=IFERROR(AVERAGEIFS(" + GRA(nameIndex) + "," + GRA(dateIndex) + ",R2C," + GRA(cellNameIndex) + ",RC1" + "),"""")"
where GRA is a function that returns the address of the range of a column.
Private Function GRA(ByRef rngIndex As Long)
GRA = "DB!" + CStr(Range(Cells(2, rngIndex), Cells(rowNos, rngIndex)).Address(1, 1, xlR1C1, 0, 0))
End Function
So given that I now filter the table beforehand how can I adjust my code so that it ignores all the hidden rows and takes into account only what is visible. Of course I am aware that a simple dirty solution would be to simply copy the filter database and paste it in a new sheet but that will affect the performance which is what I'm trying to improve.
You can use the following function to return a range of only visible cells.
Function VisibleCells(Rng As Range) As Variant
Dim R As Range
Dim Arr() As Integer
Dim RNdx As Long
Dim CNdx As Long
If Rng.Areas.Count > 1 Then
VisibleCells = CVErr(xlErrRef)
Exit Function
End If
ReDim Arr(1 To Rng.Rows.Count, 1 To Rng.Columns.Count)
For RNdx = 1 To Rng.Rows.Count
For CNdx = 1 To Rng.Columns.Count
Set R = Rng(RNdx, CNdx)
If (R.EntireRow.Hidden = True) Or _
(R.EntireColumn.Hidden = True) Then
Arr(RNdx, CNdx) = 0
Else
Arr(RNdx, CNdx) = 1
End If
Next CNdx
Next RNdx
VisibleCells = Arr
End Function
The above code came from http://www.cpearson.com/excel/VisibleCells.aspx.
Normally I would only post code that I write however this does exactly what I was thinking.
I have a dated CS degree so I understand the basics of VB but I don't write macros very often and need help solving a particular condition. (...but I understand functions and object oriented programming)
Assume the following:
- Column A contains reference ID's in alphanumeric form, sorted alphabetically.
- Column B contains strings of text, or blanks.
I'm trying to write a macro that automatically removes any extra rows for each unique reference number based on the contents of the "Notes" in column B. The problem is that if column A has multiple instances of a unique ref number, I need to identify which row contains something in column B. There is one catch: it is possible that the reference number has nothing in column B and should be retained.
To explain further, in the following screenshot I would need to:
Keep the yellow highlighted rows
Delete the remaining rows
I tried to show various configurations of how the report might show the data using the brackets on the right and marked in red. Its difficult to explain what I'm trying to do so I figured a picture would show what I need more clearly.
This task is making the report very manual and time consuming.
it's pretty simple
you just go throug the rows and check whether this row needs to be deleted, an earlier row with this id needs to be deleted or nothing should happen.
in my example i mark these rows and delete them in the end.
Sub foo()
Dim rngSelection As Range
Dim startingRow As Integer
Dim endRow As Integer
Dim idColumn As Integer
Dim noteColumn As Integer
Dim idValuableRow As New Dictionary
Dim deleteRows As New Collection
Set rngSelection = Selection
startingRow = rngSelection.Row
endRow = rngSelection.Rows.Count + startingRow - 1
idColumn = rngSelection.Column
noteColumn = idColumn + 1
For i = startingRow To endRow
currentID = Cells(i, idColumn)
If idValuableRow.Exists(currentID) Then
If Trim(idValuableRow(currentID)("note")) <> "" And Trim(Cells(i, noteColumn)) = "" Then
deleteRows.Add i
ElseIf idValuableRow(currentID)("note") = "" And Trim(Cells(i, noteColumn)) <> "" Then
deleteRows.Add idValuableRow(currentID)("row")
idValuableRow(currentID)("row") = i
idValuableRow(currentID)("note") = Cells(i, noteColumn)
End If
Else
Dim arr(2) As Variant
idValuableRow.Add currentID, New Dictionary
idValuableRow(currentID).Add "row", i
idValuableRow(currentID).Add "note", Cells(i, noteColumn)
End If
Next i
deletedRows = 0
For Each element In deleteRows
If element <> "" Then
Rows(element - deletedRows & ":" & element - deletedRows).Select
Selection.Delete Shift:=xlUp
deletedRows = deletedRows + 1
End If
Next element
End Sub
it could look something like this. the only thing you need is to add Microsoft Scripting Runtime in Tools/References