I'm trying sort a predetermined range of cells from a UserForm (let's say A1:A5) using an array size as an integer, and the array itself. I've checked out 20+ links without finding a solution.
The code below successfully gets the values of the array (for my testing there are five doubles), pastes them into the worksheet sheetOperations (I always use code-targeted sheets to minimize issues). So the sheet targeting works, and the looping through the array and getting the values works.
Sorting the range (A1:A5) hasn't been successful. I've tried a variety of code. I'm trying to get A1 to A5 (on that specific worksheet) to list the previous values in the range in descending order - when I run this code (I tried ascending, descending) it has given me various errors such 1004, etc.
If A1:A5 is {1,3,2, 4, 6}, I want it to make A1:A5 {6,4,2,3,1}.
Sub timeStampStorePart2(ByRef doubleArray() As Double, ByVal size As Integer)
Dim ws As Worksheet
Dim wsFound2 As Worksheet
For Each ws In ThisWorkbook.Worksheets
If StrComp(ws.CodeName, "sheetOperations", vbTextCompare) = 0 Then
Set wsFound2 = ws
'MsgBox ("Found")
End If
Next ws
Dim loopInt As Integer
Dim arrayInt As Integer
Dim rangeAddress As String
arrayInt = 0
loopInt = 1
For loopInt = 1 To size
rangeAddress = "A" & loopInt
wsFound2.Range(rangeAddress).Value = doubleArray(arrayInt)
arrayInt = arrayInt + 1
Next loopInt
'rangeAddress = "A1:" & rangeAddress
'MsgBox (rangeAddress)
'Dim dataRange As Range
'Set dataRange = wsFound2.Range(rangeAddress)
wsFound2.Range("A1:A5").Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlNo
End Sub
In answer to your question, here is a pretty simple code that sorts the range you describe using an array...
slightly updated to meet the integer requirement.
Sub sortStuff()
Const addr As String = "A1:A6"
Dim WS As Worksheet: Set WS = ActiveSheet 'or whatever the sheet ID name is
Dim sRNG As Range: Set sRNG = WS.Range(addr)
'changed this from first answer to integer requirement and optimize code
ReDim aRay(1 To sRNG.Rows.Count, 1 To sRNG.Columns.Count) As Integer
Dim x As Long, y As Long
For x = LBound(aRay, 1) To UBound(aRay, 1)
For y = LBound(aRay, 2) To UBound(aRay, 2)
aRay(x, y) = Application.WorksheetFunction.Large(sRNG.Columns(y), x)
Next y
Next x
'Puts into excel
sRNG = aRay
End Sub
Related
I want to copy a range of cells (custom format) filled with time data (e.g. 8:00, 7:30, 5:45, ...) as text to write to another program through Application.SendKeys. When I grab the cells as they are, they're written out as e. g. 1.041666666 instead of 7:30. How do I copy or convert them to text? Trying to get the value/text from the whole range as I copy won't work, neither did attempts at looping through afterwards to change the values separately. There might be workarounds using clipboard, but I want to leave it untouched. Code right now:
DayArray = Application.ActiveSheet.Range("A1:E4")
For j = 1 To UBound(DayArray)
For k = 1 To 5 'fixed column count
DayArray(j, k)= DayArray(j, k).Text
Next k
Next j
(... SendKeys example)
Application.SendKeys DayArray(1, 1), True
Use the Format() Function. It returns a string in the format desired:
DayArray = Application.ActiveSheet.Range("A1:E4")
For j = 1 To UBound(DayArray)
For k = 1 To 5 'fixed column count
DayArray(j, k)= Format(DayArray(j, k),"h:mm")
Next k
Next j
Time Range to Strings in a 2D one-based Array
Try:
Dim ws As Worksheet: Set ws = ActiveSheet
Dim DayArray() As Variant: DayArray = ws.[TEXT(A1:E4,"h:mm")]
or just (for the ActiveSheet exclusively):
Dim DayArray() As Variant: DayArray = [TEXT(A1:E4,"h:mm")]
Or an Evaluate one-liner function...
Function GetTimeRange( _
ByVal rg As Range) _
As Variant
GetTimeRange = rg.Worksheet.Evaluate("TEXT(" & rg.Address & ",""h:mm"")")
End Function
... to be used e.g. in the following way:
Sub GetTimeRangeTEST()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim rg As Range: Set rg = ws.Range("A1:E4")
Dim Data As Variant: Data = GetTimeRange(rg)
ws.Range("G1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
i have list of numbers B201:B523 . i want to extract 30 random numbers from this list in E200:E230.
i used this code. It is giving only 1 random number in all output cell.
Sub Generate_random_values_from_a_column()
'declare a variable
Dim ws As Worksheet
Set ws = Worksheets("sheet1")
ws.Range("e200:e229") = WorksheetFunction.Index(Range("B201:B523"), WorksheetFunction.RandBetween(1, ws.Range("B201:B523").Rows.Count), 1)
End Sub
then i tried some other codes but those were worse then this.
We can put the formula first in the cell and then change it to values.
Sub Generate_random_values_from_a_column()
'declare a variable
Dim ws As Worksheet
Set ws = Worksheets("sheet1")
With ws
.Range("e200:e229").Formula = "=RANDBETWEEN(1, " & .Range("B201:B523").Rows.Count & ")"
.Range("e200:e229").Value = .Range("e200:e229").Value
End With
End Sub
Your code is returning 1 random number because it only calculates WorksheetFunction.RandBetween(1, ws.Range("B201:B523").Rows.Count) once.
Try the code below, I have tried to comment as detailed as possible but ask if you don't understand any part.
Sub GetUniqueRandomNum()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("sheet1")
Const outputCount As Long = 30 'Number of output you want
Const outputFirstCell As String = "E200" 'Address of the output first cell
Const numStartRow As Long = 201 'First row of the list of numbers
Const numEndRow As Long = 523 'Last row of the list of numbers
Const numColumn As Long = 2 'Column index of the list of numbers
'Store the values of the list of numbers in an array (to avoid reading from cells unnecessary)
Dim numList As Variant
numList = ws.Range(ws.Cells(numStartRow, numColumn), ws.Cells(numEndRow, numColumn)).Value
Dim uniqueNum As Object
Set uniqueNum = CreateObject("Scripting.Dictionary")
'Generate a random number and add the corresponding value in dictionary if it does not exist, stop once it has 30 entires
Do While uniqueNum.Count <> outputCount
Dim inputVal As Long
inputVal = Application.RandBetween(1, UBound(numList))
If Not uniqueNum.Exists(numList(inputVal, 1)) Then
uniqueNum.Add (numList(inputVal, 1)), 1
End If
Loop
Dim uniqueList As Variant
uniqueList = uniqueNum.Keys
'Write output to worksheet
ws.Range(outputFirstCell).Resize(outputCount).Value = Application.WorksheetFunction.Transpose(uniqueList)
End Sub
I'm trying to write a VBA code thta helps me Vlookup value from another location on C Drive, but apparently only the first two cells work.
Could you help me correct this code? Really new to VBA and just trying my waters with the Do While Looops.
Sub Copy3()
Dim lookfor As Range
Dim table_array As Range
Dim table_array_col As Integer
Dim lookFor_col As Integer
Dim Wbk As Workbook
Dim Rows As Integer
Rows = 2
Do While Rows < 60
Set lookfor = Cells(Rows, 1)
Set Wbk = Workbooks.Open("C:\Users\XXX.xlsx")
Set table_array = Wbk.Sheets("Sheet1").Range("B2:H60")
table_array_col = 5
lookFor_col = ThisWorkbook.Sheets("Sheet1").UsedRange.Columns.Count - 2
ThisWorkbook.Sheets("Sheet1").Cells(Rows, lookFor_col).Formula = Application.VLookup(lookfor.Value, table_array, table_array_col, 0)
Rows = Rows + 1
Loop
End Sub
I think I found the error. Set lookfor = Cells(Rows, 1) was missing a qualifier, and was likely not referencing the correct workbook. Workbooks.Open changes the Active Workbook. Unqualified ranges are prone to cause errors when the Active Workbook changes during execution.
I corrected that by adding a reference to ThisWorkbook.Sheets("Sheet1") and also cleaned up some other minor problems that I noticed. Notably, Rows is one of the Range Objects built into Excel VBA. Its best to avoid using defined object names as your variable names when you can.
Sub Copy3()
Const table_array_col As Integer = 5
Dim lookfor As Range
Dim Row As Integer
Dim lookFor_col As Integer
lookFor_col = Sh.UsedRange.Columns.Count - 2
Dim Wbk As Workbook
Set Wbk = Workbooks.Open("C:\Users\XXX.xlsx")
Dim table_array As Range
Set table_array = Wbk.Sheets("Sheet1").Range("B2:H60")
Dim Sh As Worksheet
Set Sh = ThisWorkbook.Sheets("Sheet1")
For Row = 2 To 59
Set lookfor = Sh.Cells(Row, 1)
Sh.Cells(Row, lookFor_col).Value = Application.VLookup(lookfor.Value, table_array, table_array_col, 0)
Next Row
End Sub
I struggle with VBA and have spent a few days trying to find a solution to this problem. Essentially, I have two spreadsheets with large sets of data. Column K of "Design Mods" worksheet contains the same types of values as Column C of the "Output" Worksheet. I've been trying to get my script to do the following:
1. for each cell in column k of "Design Mods", check if there is a matching cell in column c of the "output" spreadsheet
2. if a match is found, then populate the cell in "Design Mods" to columns over with the information from column b of "Output"
Because of my lack of experience, I've only been able to setup the script below which only checks and pulls correctly for one cell.
I need it to check each cell against a range of other cells.
Any help/guidance would be very much appreciated.
Thank you very much!
Sub MatchValue_Test()
'Routine is meant to populate columns "Design Mods" Spreadsheet with affected calculations from the "Output" Spreadsheet
'Variables below refer to Design Mods spreadsheet
Dim designmod As Worksheet '<-- Design Mods worksheet that we are comparing to the Output Data
Dim DesignMod_DClrow As Integer '<-- Variable used to count to the last low in the DC Number Column of Design Mods Spreadsheet
Dim designmoddc As Range '<-- Variable used to identify the range of values being checked in Design Mods is the DC Numbers Column K from K4 to the end of the column
Dim valuetofind As String '<-- DC Number used as matching criteria between Design Mods spreadsheet and Output Data
'Test Variables for integrating references to from Output worksheet
Dim testset As Worksheet
Dim test2_lrow As Integer
Dim test As Range
Dim valuetofindw2 As String
'Variables below pertain the routine itself
Dim found As Boolean '<-- this condition has to be false to start the routine
'Start of Routine
found = False
'Definition of Data Ranges in Design Mods spreadsheet
Set designmod = ActiveWorkbook.Worksheets("Sheet1")
DesignMod_DClrow = designmod.Range("K4").End(xlDown).Row
Set designmoddc = designmod.Range("K4:K" & DesignMod_DClrow)
'Test variables for integrating values from Output worksheet
Set testset = ActiveWorkbook.Worksheets("Sheet2")
test2_lrow = testset.Range("C2").End(xlDown).Row
Set test = testset.Range("C2:C" & test2_lrow)
'Identify the value being matched against
valuetofind = designmod.Range("L4").Value '<-- the script wont run if I have this value set to a range, and I need to figure out get this to loop so I don't need a variable for every cell im checking against
'test variables to figure out if statement
valuetofindw2 = testset.Range("C2").Value
valuetofindw3 = testset.Range("B2").Value
valuetofindw4 = designmod.Range("K4")
'If Statements performing the comparison
For Each Cell In designmoddc
If Cell.Value = valuetofindw3 Then
found = True
End If
Next
If found = True Then
designmoddc.Cells.Offset(0, 2).Value = testset.Range("B2")
End If
End Sub
You did not answer my clarification questions...
I prepared a solution, able to work very fast (using arrays). Please back-up your workbook, because the code will rewrite the matching cases in column M:M.
Sub MatchValue_TestArrays()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, boolFound As Boolean
Set designMod = Worksheets("Sheet1")
Set testSet = Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:M" & lastRowD).value 'load the range in array
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, 3) = arrTest(t, 1)'fill the array third column (M:M) with values of B:B testSheet...
Exit For
End If
Next t
Next d
designMod.Range("K4:M" & lastRowD).value = arrDes' Drop the modified array
End Sub
Try the updated code, please. It searches now for all occurrences and put each one in a consecutive column:
Sub MatchValue_TestArrays_Extended()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, col As Long
Set designMod = Worksheets("Design") ' Worksheets("Sheet1")
Set testSet = Worksheets("TestS") ' Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:AQ" & lastRowD).value
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
col = 3 'the column where the occurrence will be put
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, col) = arrTest(t, 1): col = col + 1
End If
Next t
Next d
designMod.Range("K4:AQ" & lastRowD).value = arrDes
End Sub
Using Match() is fast when your data is on a worksheet:
Sub MatchValue_Test()
Dim wsDesign As Worksheet, wsOut As Worksheet, m, c As Range
Set wsDesign = ActiveWorkbook.Worksheets("Sheet1")
Set wsOut = ActiveWorkbook.Worksheets("Sheet2")
For Each c In wsDesign.Range(wsDesign.Range("K4"), _
wsDesign.Cells(Rows.Count, "k").End(xlUp)).Cells
m = Application.Match(c.Value, wsOut.Columns("C"), 0)
If Not IsError(m) Then
'if Match() found a hit then m will be the row number on sheet2
c.Offset(0, 2).Value = wsOut.Cells(m, "B").Value
End If
Next c
End Sub
Pretty basic question here but my VBA skills are pretty rusty. I have two worksheets where a machine just dumps data into them. Each sheet is just one column and SheetA has ~250 rows and SheetB has ~1300 rows. So what I need to do is compare the first value in sheetA to every value in sheetB, if a match is found I need to copy it to another sheet (SheetC) and then move to the next value in SheetA and repeat this till every value in SheetA has been compared to every value in SheetB. I think the best way to do this is with arrays but I cannot for the life of me remember how to do the actual comparison. Below is the code calling up the sheets and arrays I think....any help is appreciated!
Dim SheetA As Variant
Dim SheetB As Variant
Dim RangeToCheckA As String
Dim RangeToCheckB As String
'Get the worksheets from the workbooks
Set wbkA = Workbooks.Open(Filename:="H:\Chelsea QE\CD6\Evan West\OSM37 with locations 9-30-19.xls")
Set SheetA = wbkA.Worksheets("OSM37")
Set wbkB = Workbooks.Open(Filename:="H:\Chelsea QE\CD6\Evan West\New folder\Flat Rock and Roush VIN Tracker U625 - U611 Lower control arm welds.xlsx")
Set SheetB = wbkB.Worksheets("Master VIN")
'This is the range in SheetA
RangeToCheckA = "B2:B239"
'This is the range in SheetB
RangeToCheckB = "B4:B1339"
SheetA = SheetA.Range(RangeToCheckA)
SheetB = SheetB.Range(RangeToCheckB)
Without changing much of your code and adding a call to a custom function, you could do the following:
Private Sub CompareWorkBooks()
Dim wbkA As Workbook, wbkB As Workbook
Dim SheetA As Worksheet, SheetB As Worksheet, SheetC As Worksheet
Dim RangeToCheckA As String
Dim RangeToCheckB As String
Dim arrySheetA() As Variant, arrySheetB() As Variant, _
arryOut() As Variant
'Get the worksheets from the workbooks
Set wbkA = Workbooks.Open(Filename:="H:\Chelsea QE\CD6\Evan West\OSM37 with locations 9-30-19.xls")
Set SheetA = wbkA.Worksheets("OSM37")
Set wbkB = Workbooks.Open(Filename:="H:\Chelsea QE\CD6\Evan West\New folder\Flat Rock and Roush VIN Tracker U625 - U611 Lower control arm welds.xlsx")
Set SheetB = wbkB.Worksheets("Master VIN")
'This is the range in SheetA
RangeToCheckA = "B2:B239"
'This is the range in SheetB
RangeToCheckB = "B4:B1339"
'Value 2 is faster as it doesn't copy formatting
arrySheetA() = SheetA.Range(RangeToCheckA).Value2
arrySheetB() = SheetB.Range(RangeToCheckB).Value2
Set SheetC = wbkB.Worksheets("Sheet C")
arryOut() = FastLookUp(arrySheetA, arrySheetB, 1, 1, 1)
SheetC.Range("A1").Resize(UBound(arryOut, 1), _
UBound(arryOut, 2)).Value = arryOut
End Sub
FastLookUp Function:
Private Function FastLookUp(ByRef arryLookUpVals As Variant, ByRef arryLookUpTable As Variant, _
ByVal lngLookUpValCol As Long, ByVal lngSearchCol As Long, _
ByVal lngReturnCol As Long, _
Optional ByVal boolBinaryCompare As Boolean = True) As Variant
Dim i As Long
Dim dictLooUpTblData As Object
Dim varKey As Variant
Dim arryOut() As Variant
Set dictLooUpTblData = CreateObject("Scripting.Dictionary")
If boolBinaryCompare Then
dictLooUpTblData.CompareMode = vbBinaryCompare
Else
dictLooUpTblData.CompareMode = vbTextCompare
End If
'add lookup table's lookup column to
'dictionary
For i = LBound(arryLookUpTable, 1) To UBound(arryLookUpTable, 1)
varKey = Trim(arryLookUpTable(i, lngSearchCol))
If Not dictLooUpTblData.Exists(varKey) Then
'this is called a silent add with is faster
'than the standard dictionary.Add Key,Item
'method
dictLooUpTblData(varKey) = arryLookUpTable(i, lngReturnCol)
End If
varKey = Empty
Next i
i = 0: varKey = Empty
ReDim arryOut(1 To UBound(arryLookUpVals, 1), 1 To 1)
For i = LBound(arryLookUpVals, 1) To UBound(arryLookUpVals, 1)
varKey = Trim(arryLookUpVals(i, lngLookUpValCol))
'if the lookup value exists in the dictionary
'at this index of the array, then return
'its correspoding item
If dictLooUpTblData.Exists(varKey) Then
arryOut(i, 1) = dictLooUpTblData.Item(varKey)
End If
varKey = Empty
Next i
FastLookUp = arryOut
End Function
FastLookup functions exactly like a VLOOKUP, but is a bit more flexible, because the the lookup column does not have to be the first one in the range you are looking up, as you are allowed to specify which column by providing a value for lngLookUpValCol parameter.
Concerning that you have 3 worksheets in 1 workbook - Worksheets(1) and Worksheets(2) are the one, in which the values in Range("A1:A7") and Range("A1:A3") are compared:
Sub TestMe()
Dim arrA As Variant
Dim arrB As Variant
With Application
arrA = .Transpose(Worksheets(1).Range("A1:A7"))
arrB = .Transpose(Worksheets(2).Range("A1:A3"))
End With
Dim a As Variant
Dim b As Variant
For Each a In arrA
For Each b In arrB
If a = b Then
Worksheets(3).Cells(1 + LastRow(Worksheets(3).Name), 1) = b
End If
Next
Next
End Sub
Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
If you are planning to use the code above, it is a good idea to make sure that the values in Worksheets(1) are all unique, otherwise the code would repeat them N times. Or add a dictionary, to exclude repeated values.