I have a code that puts spaces in a column of numbers, so that each group of 6 numbers have 2 spaces between them, starting from the top of the sheet. After the groups of 6 there can be groups of 5, these need to have 3 spaces between them.
The groups of 6 always appear above the groups of 5.
I would like to have a code that asks how many groups of 6, then asks for how many groups of 5, then puts in the relevant spacing.
Sub MacroMan()
Dim x As Integer
x = 8
For i = 1 To CInt(InputBox("Run this many times:"))
'Range("H2").Paste
Application.CutCopyMode = False
Range("H&x:H&x+1").Insert Shift:=xlDown
'Range("H2:H110").Copy
x = x + 8
Next
End Sub
I've got the code to run now, but I get the following error.
Run-time error '1004'
Method 'Range of object'_'Global'failed
You can ask the user for their input and store the answer in a string. Then convert the string to an integer and use it to determine the number of loops.
sub AskUser
dim Answer as string
dim i as integer
dim Number as integer
Answer = Inputbox("Your text here")
Number = CInt(Answer) 'Note this will throw an error if you enter something that's not a numbeer
for i = 1 to Number
'code
next i
End sub
This should do the same thing, for the amount of times that you specify.
Important: Always run untested code on a copy of your data as executed code cannot be undone!
Sub SO()
Dim x As Integer, i As Integer
x = 8
Application.CutCopyMode = False
For i = 1 To CInt(InputBox("Run this many times:"))
Range("H" & x & ":H" & x + 1).Insert Shift:=xlDown
x = x + 8
Next
End Sub
Related
I am creating a third party add in for my CAD program that has a sub in it that goes through a drawing and finds all the parts lists (BOMS), if any items in the parts list are shared between the BOM (1 part being used in 2 weldments for example) then it changes the item number of the second instance to be that of the first instance. It does this by comparing full file names between the two values. When they match change the number to that of the matcher. I have got this to work but it runs a little slow because for a 100 item BOM each item is compared to 100 and thus that takes a little longer then I would like (about 60seconds to run). After thinking about it I realized I did not need to compare each item to all the items, I just needed to compare until it found a duplicate and then exit the search loop and go to the next value. Example being Item 1 does not need to compare to the rest of the 99 values because even if it does have a match in position 100 I do not want to change item 1s number to that of item 100. I want to change item 100 to that of 1(ie change the duplpicate to that of the first encountered double). For my code however I am having trouble exiting the comparison for loops which is causing me trouble. An example of the trouble is this:
I have 3 BOMs, each one shares Part X, and is numbered 1 in BOM 1, 4 in BOM 2, and 7 in BOM 3. when I run my button because I cannot get it to leave the comparison loop once it finds it first match all the Part X's ended up getting item number 7 from BOM 3 because it is the last instance. (I can get this to do what I want by stepping through my for loops backwards and thus everything ends up as the top most occurrence, but I would like to get my exit fors working because it saves me on unnecessary comparisons)
How do I go about breaking out of the nested for loops using an if conditional?
Here is my current code:
Public Sub MatchingNumberR1()
Debug.Print ThisApplication.Caption
'define active document as drawing doc. Will produce an error if its not a drawing doc
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
'Store all the sheets of drawing
Dim oSheets As Sheets
Set oSheets = oDrawDoc.Sheets
Dim oSheet As Sheet
'Loop through all the sheets
For Each oSheet In oSheets
Dim oPartsLists As PartsLists
Set oPartsLists = oSheet.PartsLists
'Loop through all the part lists on that sheet
Dim oPartList As PartsList
'For every parts list on the sheet
For Each oPartList In oPartsLists
For i3 = 1 To oPartList.PartsListRows.Count
'Store the Item number and file referenced in that row to compare
oItem = FindItem(oPartList)
oDescription = FindDescription(oPartList)
oDescripCheck = oPartList.PartsListRows.Item(i3).Item(oDescription).Value
oNumCheck = oPartList.PartsListRows.Item(i3).Item(oItem).Value
'Check to see if the BOM item is a virtual component if it is do not try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count = 0 Then
oRefPart = " "
End If
'Check to see if the BOM item is a virtual component if it is try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count > 0 Then
oRefPart = oPartList.PartsListRows.Item(i3).ReferencedFiles.Item(1).FullFileName
End If
MsgBox (" We are comparing " & oRefPart)
'''''Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match.'''''
'Store all the sheets of drawing
Dim oSheets2 As Sheets
Set oSheets2 = oDrawDoc.Sheets
Dim oSheet2 As Sheet
'For every sheet in the drawing
For Each oSheet2 In oSheets2
'Get all the parts list on a single sheet
Dim oPartsLists2 As PartsLists
Set oPartsLists2 = oSheet2.PartsLists
Dim oPartList2 As PartsList
'For every parts list on the sheet
For Each oPartList2 In oPartsLists2
oItem2 = FindItem(oPartList2)
oDescription2 = FindDescription(oPartList2)
'Go through all the rows of the part list
For i6 = 1 To oPartList2.PartsListRows.Count
'Check to see if the part is a not a virtual component, if not, get the relevent comparison values
If oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count > 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oRefPart2 = oPartList2.PartsListRows.Item(i6).ReferencedFiles.Item(1).FullFileName
'Compare the file names, if they match change the part list item number for the original to that of the match
If oRefPart = oRefPart2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
'For virtual components get the following comparison values
ElseIf oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count = 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oDescripCheck2 = oPartList2.PartsListRows.Item(i6).Item(oDescription2).Value
'Compare the descriptions and if they match change the part list item number for the original to that of the match
If oDescripCheck = oDescripCheck2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
Else
''''''''This is where if no matches were found I want it to continue going through the comparison loop'''''''
End If
Next
Next
Next
Next
Next
Next
'MsgBox ("Matching Numbers has been finished")
End Sub
For escape from nested for loop you can use GoTo and specify where.
Sub GoToTest()
Dim a, b, c As Integer
For a = 0 To 1000 Step 100
For b = 0 To 100 Step 10
For c = 0 To 10
Debug.Print vbTab & b + c
If b + c = 12 Then
GoTo nextValueForA
End If
Next
Next
nextValueForA:
Debug.Print a + b + c
Next
End Sub
Here are a few examples that demonstrate (1) breaking out of (exiting) a loop and (2) finding the values in arrays.
The intersection of 2 arrays example can be modified to meet your need to "Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match." Note, you may find multiple matches between 2 arrays.
Option Explicit
Option Base 0
' Example - break out of loop when condition met.
Public Sub ExitLoopExample()
Dim i As Integer, j As Integer
' let's loop 101 times
For i = 0 To 100:
j = i * 2
'Print the current loop number to the Immediate window
Debug.Print i, j
' Let's decide to break out of the loop is some
' condition is met. In this example, we exit
' the loop if j>=10. However, any condition can
' be used.
If j >= 10 Then Exit For
Next i
End Sub
' Example - break out of inner loop when condition met.
Public Sub ExitLoopExample2()
Dim i As Integer, j As Integer
For i = 1 To 5:
For j = 1 To 5
Debug.Print i, j
' if j >= 2 then, exit the inner loop.
If j >= 2 Then Exit For
Next j
Next i
End Sub
Public Sub FindItemInArrayExample():
' Find variable n in array arr.
Dim intToFind As Integer
Dim arrToSearch As Variant
Dim x, y
intToFind = 4
arrToSearch = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
x = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(x) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; x
End If
intToFind = 12
y = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(y) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; y
End If
End Sub
Public Function FindItemInArray(FindMe, ArrayToSearch As Variant):
Dim i As Integer
For i = LBound(ArrayToSearch) To UBound(ArrayToSearch)
If FindMe = ArrayToSearch(i) Then
FindItemInArray = ArrayToSearch(i)
Exit For
End If
Next i
End Function
' Create a comparison loop to go through the drawing that checks
' the oRefPart against other BOM items and see if there is a match.
Public Sub ArrayIntersectionExample():
Dim exampleArray1 As Variant, exampleArray2 As Variant
Dim arrIntersect As Variant
Dim i As Integer
' Create two sample arrays to compare
exampleArray1 = Array(1, 2, 3, 4, 5, 6, 7)
exampleArray2 = Array(2, 4, 6, 8, 10, 12, 14, 16)
' Call our ArrayIntersect function (defined below)
arrIntersect = ArrayIntersect(exampleArray1, exampleArray2)
' Print the results to the Immediate window
For i = LBound(arrIntersect) To UBound(arrIntersect)
Debug.Print "match " & i + 1, arrIntersect(i)
Next i
End Sub
Public Function ArrayIntersect(arr1 As Variant, arr2 As Variant) As Variant:
' Find items that exist in both arr1 and arr2 (intersection).
' Return the intersection as an array (Variant).
Dim arrOut() As Variant
Dim matchIndex As Long
Dim i As Long, j As Long
' no matches yet
matchIndex = -1
' begin looping through arr1
For i = LBound(arr1) To UBound(arr1)
' sub-loop for arr2 for each item in arr1
For j = LBound(arr2) To UBound(arr2)
' check for match
If arr1(i) = arr2(j) Then
' we found an item in both arrays
' increment match counter, which we'll
' use to size our output array
matchIndex = matchIndex + 1
' resize our output array to fit the
' new match
ReDim Preserve arrOut(matchIndex)
' now store the new match our output array
arrOut(matchIndex) = arr1(i)
End If
Next j
Next i
' Have the function return the output array.
ArrayIntersect = arrOut
End Function
I am trying to use two VLookUps in a row in my macro. The macro counts the IDs in column A and C, searches for the ID description in another table (same sheet and ranges from column F to M -> F = IDs, H = ID description) and continues this search until the count is reached and inserts them in column B and D.
Unfortunately, I get a
run time error 1004
when using the second VLookUp. First one works fine and it's exactly the same as in the first one I am just referring to different cells.
Picture reference of what I am trying to achieve:
Does anyone know what causes this problem?
Dim i As Integer
Dim shA As Worksheet
Set shA = Worksheets(Format(Date, "dd.mm.yyyy"))
With shA
For i = 4 To .Range("A4", .Range("A4").End(xlDown)).Rows.Count + 3
.Cells(i, 2) = .Application.WorksheetFunction.VLookup(.Cells(i, 1), .Range("F:M"), 3, False)
Next i
For i = 4 To .Range("C4", .Range("C4").End(xlDown)).Rows.Count + 3
.Cells(i, 4) = .Application.WorksheetFunction.VLookup(.Cells(i, 3), .Range("F:M"), 3, False)
Next i
End With
Try to replace Integer with Long and try again.
In VBA Integer is
from -2^15 to 2^15-1 or
from -32768 to 32767
Thus, if you use it in Excel and it refers numbers which are outside this range, you get an error. In general, you have some other errors as well. Try this and make sure that you have the correct ActiveSheet selected (I have done it for easy, you may change it later):
Public Sub TestMe()
Dim i As Long
Dim shA As Worksheet
Set shA = ActiveSheet
With shA
For i = 4 To .Range("A4", .Range("A4").End(xlDown)).Rows.Count + 3
.Cells(i, 2) = Application.VLookup(.Cells(i, 1), .Range("F:M"), 3, False)
Next i
For i = 4 To .Range("C4", .Range("C4").End(xlDown)).Rows.Count + 3
.Cells(i, 4) = Application.VLookup(.Cells(i, 3), .Range("F:M"), 3, False)
Next i
End With
End Sub
Thus, in general:
Do not use On Error Resume Next, because it is a bit tough.
When you use With Worksheets("someName"), then make sure that every time you put a dot ., the child is a real child of the with-Parent. In your case .Application is not a child of Worksheets()
Do not use Integer, but Long
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 am having trouble figuring out how to subtract two ranges from each other, some cells in range H:H have "#N/A" while in range D:D there are no errors. I know in Excel it's a simple "=H2-D2" and drag that down but I'm in the process of recording a Macro and wanted to automate the subtraction as well. So far this is what I have:
Dim quantity1, quantity2, rIntersect, Qdiff, x As Range
Set quantity1 = Range("D:D")
Set quantity2 = Range("H:H")
Set rIntersect = Intersect(quantity1, quantity2)
For Each x In quantity1
If Intersect(rIntersect, x) Is Nothing Then
If Qdiff Is Nothing Then
Set Qdiff = x
Else
Set Qdiff = Application.Union(Qdiff, x)
End If
End If
Next x
Range("J2").Select
Dim lastRowJ As Long
lastRowJ = Range("A" & Rows.Count).End(xlUp).Row
Range("J2").AutoFill Destination:=Range("J2:J" & lastRowJ)
Place this procedure in a standard code module:
Public Sub Subtract()
[j2:j99] = [h2:h99-d2:d99]
End Sub
If you like how that works, I'm happy to embellish it so that it is not hard-coded for 98 rows only. Let me know.
UPDATE
Here is a version that will deal with any number of rows. It keys off of column D. So if there are 567 numbers in column D, then you will get 567 corresponding (subtracted) results in column J.
This assumes that the data start in row 2, and that there are no blank cells until the numbers in column D end.
If you are going to call this from the Macro Dialog then you should keep it Public. If on the other hand you are going to call it from another procedure in the same module, then you can make it Private.
Here is the enhanced solution:
Public Sub Subtract()
Dim k&
Const F = "iferror(h2:h[]-d2:d[],0)"
k = [count(d:d)]
[j2].Resize(k) = Evaluate(Replace(F, "[]", k + 1))
End Sub
Note that the routine now handles the errors and places a ZERO value in column J when the corresponding value in column H is an error. If you would prefer to have something other than a ZERO (like a blank for instance) when there are errors in column H, just let me know and I'll update to whatever you want.
UPDATE 2
Here is how to handle displaying blanks instead of zeroes:
Public Sub Subtract()
Dim k&
Const F = "iferror(if(h2:h[]-d2:d[]=0,"""",h2:h[]-d2:d[]),0)"
k = [count(d:d)]
[k2].Resize(k) = Evaluate(Replace(F, "[]", k + 1))
End Sub
I am writing a subroutine in VBA to cycle through all the listed job numbers in a multi-tab time sheet and create a list of all job numbers that have been used (so it takes the original list (with possibly multiple job number occurrences) and creates a list with only one occurrence of each job number. The job numbers on each sheet are found in range("A8:A30"). The code below seems to work for the first several job names on the sample that I'm testing, but then seems to stop filtering. A8:A21 of the first sheet is:
14GCI393
14GCI393
13GCI373
13GCI373
13GCI388
13GCI367:2
14GCI408
14GCI408
13GCI373
13GCI388
14GCI415
14GCI415
00GCI000
And the code is:
Sub listusedjobs()
Dim usedjobs() As String
Dim nextjob As String
Dim i, m, n, lastsheetindexnumber As Integer
Application.ScreenUpdating = False
lastsheetindexnumber = ThisWorkbook.Sheets.Count
m = 0
ReDim usedjobs(m)
usedjobs(m) = "initialize"
For i = 1 To lastsheetindexnumber
Sheets(i).Activate
For n = 8 To 30
nextjob = Range("A" & n).Value
If Not IsInArray(nextjob, usedjobs) Then 'determine if nextjob is already in usedjobs()
ReDim usedjobs(m)
usedjobs(m) = nextjob 'Add each unique job to array "usedjobs"
Sheets(lastsheetindexnumber).Cells(m + 40, 1).Value = nextjob 'Print job name that was just added
m = m + 1
End If
Next n
Next i
Application.ScreenUpdating = True
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound, , vbTextCompare)) > -1)
End Function
Any help figuring out what is going wrong will be much appreciated! The current output I get for this code is below and contains multiple doubles.
14GCI393
13GCI373
13GCI388
13GCI367:2
14GCI408
13GCI373
13GCI388
14GCI415
00GCI000
I think that your problem may be not using ReDim Preserve inside your If Not