I would like to seek your help for my issue:
I would like to check if the row value in Column Q of Workbook A is "WIN".
If yes, then return 1 in the corresponding row in Column BL of Workbook A.
If no, then return 0 in the corresponding row in Column BL of Workbook A.
I have applied a VBA-based array to carry out the check but unfortunately, I am only getting 1, not 0...
My (non-working) code is below:
Dim ws As Worksheet
Dim j, LastRowOutcomeCleaned As Long
Dim arrQ, arrBL As Variant
Dim answer, found As Range
Set ws = Workbooks("A.xlsx").Sheets(2)
LastRow = ws.Range("Q" & Rows.Count).End(xlUp).Row
arrQ = ws.Range("Q2:Q" & LastRow).Value
arrBL = ws.Range("BL2:BL" & LastRow).Value
ReDim arrBL(1 To UBound(arrQ), 1 To 1)
For j = 1 To UBound(arrQ)
answer = "WIN"
Set found = ws.Columns("Q:Q").Find(what:=answer)
If found Is Nothing Then
arrBL(j, 1) = "0"
Else
arrBL(j, 1) = "1"
End If
Next j
ws.Range("BL1").Resize(UBound(arrBL), 1).Value = arrBL
Many thanks!
Find will search the entire column each time in the loop so if the value exist anywhere in the column the whole output array will return 1. If you want a row by row test then test each row:
Dim ws As Worksheet
Dim j As Long, LastRowOutcomeCleaned As Long
Dim arrQ as Variant, arrBL As Variant
Dim answer as string
'Note: this is dangerous as the order of sheets may change
' Consider using the codename instead.
Set ws = Workbooks("A.xlsx").Sheets(2)
LastRow = ws.Range("Q" & Rows.Count).End(xlUp).Row
arrQ = ws.Range("Q2:Q" & LastRow).Value
'Next line not needed as you redim it right after.
'arrBL = ws.Range("BL2:BL" & LastRow).Value
ReDim arrBL(1 To UBound(arrQ), 1 To 1)
For j = 1 To UBound(arrQ)
answer = "WIN"
If arrQ(j,1)=answer Then
arrBL(j, 1) = 1
Else
arrBL(j, 1) = 0
End If
Next j
ws.Range("BL1").Resize(UBound(arrBL), 1).Value = arrBL
Related
I am looking for if it is possible to get the data and headers from a table as in the example image and have the output go to two columns with the first column being a repeating header? I did try the transpose however the email row kept populating up to column E.
Please, try the next way. It uses arrays being fast even for large ranges, mostly working in memory. It returns starting from "F2". It is able to process any other columns you (may) need, after "Status":
Sub TransposeMails()
Dim sh As Worksheet, lastR As Long, lastCol As Long
Dim arrH, arr, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet 'use here the necessary sheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column 'last column
arrH = Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2) 'place headers in an array
arr = sh.Range("A2", sh.cells(lastR, lastCol)).Value2 'place the range to be processed (except headers) in an array for faster iteration/processing
ReDim arrFin(1 To (UBound(arrH) + 1) * UBound(arr), 1 To 2) 'Redim the final array (keeping the processed result)
'+ 1 for the empty rows in between...
For i = 1 To UBound(arr)
For j = 1 To UBound(arrH)
k = k + 1
arrFin(k, 1) = arrH(j, 1): arrFin(k, 2) = arr(i, j)
Next j
k = k + 1 'for the empty row between groups...
Next i
'drop the processed array content:
sh.Range("G2").Resize(UBound(arrFin), 2).Value2 = arrFin
End Sub
The code can be easily adapted to return anywhere (another sheet, workbook, range etc).
The range to be processed must start from "A1" ("Email" header) and not having any other record after the last header (on the first row)...
Transpose Data
Sub TransposeData()
Const SRC_NAME As String = "Sheet1"
Const DST_NAME As String = "Sheet1"
Const DST_FIRST_CELL As String = "A8"
Const EMPTY_COLS As Long = 0
Const EMPTY_ROWS As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim drOffset As Long: drOffset = srg.Columns.Count + EMPTY_ROWS
Dim dcOffset As Long: dcOffset = 1 + EMPTY_COLS
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Application.ScreenUpdating = False
Dim srrg As Range, shrg As Range
Dim IsHeaderReady As Boolean, IsFirstRowDone As Boolean
For Each srrg In srg.Rows
If Not IsHeaderReady Then
srrg.Copy
dfCell.PasteSpecial Transpose:=True
Set shrg = dfCell.Resize(srg.Columns.Count) ' transpose no more
IsHeaderReady = True
Else ' header is ready; it's already copied for the first data row
If IsFirstRowDone Then shrg.Copy dfCell Else IsFirstRowDone = True
srrg.Copy
dfCell.Offset(, dcOffset).PasteSpecial Transpose:=True
Set dfCell = dfCell.Offset(drOffset)
End If
Next srrg
Application.ScreenUpdating = True
MsgBox "Data transposed.", vbInformation
End Sub
If I understand you correctly
Sub test()
'set the range of the header as rg variable
'count how many data under EMAIL header as cnt variable
Dim rg As Range: Set rg = Range("A1", Range("A1").End(xlToRight))
Dim cnt As Integer: cnt = Range(rg, rg.End(xlDown)).Rows.Count - 1
Dim i As Integer: Dim rslt As Range
'loop to each range with data as many as the cnt value
'prepare the result range as rslt variable
'put the value of header name to rslt range
'put the looped range value to rslt.offset(0,1)
For i = 1 To cnt
Set rslt = Range("A" & Rows.Count).End(xlUp).Offset(3, 0) _
.Resize(rg.Columns.Count, 1)
rslt.Value = Application.Transpose(rg)
rslt.Offset(0, 1).Value = Application.Transpose(rg.Offset(i, 0))
Next
End Sub
Please note, the code must be run where the sheet contains the data is active.
When I run this code, it is getting a subscript out of range error in this specific line:
If i = ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1).End(xlUp).Row Then
arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = i ' <-- This line
End If
I unfortunately did not write this code, but my understanding is that i is supposed to be the upper bound of the array above. I've tried troubleshooting a bit and it appears that arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = 0 which would suggest that the Array is unallocated and therefore the error is coming from somewhere above this line. From what I have read it could be from the redim portions but I've tried ReDim arr_Test_Case_Rows(1 To 2, 1 To 1) right before the error line and while it ran, the results did not populate as expected. Anything I can do here to fix this?
Sub Populate_Test_Matrix()
Dim str_External_Test_Matrix_Name As String
Dim ws_External_Test_Matrix As Worksheet
Dim ws_TestMatrix_Tab As Worksheet
Dim ws_ItemInputs As Worksheet
Dim ws_ItemOutputs As Worksheet
Dim rng_Header_Copy_Start As Range
Dim rng_Header_Copy_End As Range
Dim rng_Copy_Start As Range
Dim rng_Copy_End As Range
Dim rng_Paste_Start As Range
Dim i As Long
Dim j As Long
Dim arr_Test_Case_Rows() As Variant
Dim boo_Empty_Row_Ind As Boolean
Dim xlx As XlXmlExportResult
Dim xmlmp As XmlMap
Dim str_Replace_String As String
Dim arr_XML_String_Holder() As Variant
Dim str_XML_Save_Name As String
Dim str_Record As String
Dim str_State As String
Dim int_Test_Case_Start_Row As Long
Application.ScreenUpdating = False
str_External_Test_Matrix_Name = Open_Workbook(ThisWorkbook.Sheets("Macro_Menu").Range("Test_Case_Matrix_Path").Value)
Set ws_External_Test_Matrix = Workbooks(str_External_Test_Matrix_Name).Sheets("MATRIX")
Set ws_TestMatrix_Tab = ThisWorkbook.Sheets("TESTMatrix")
Set ws_ItemInputs = ThisWorkbook.Sheets("ITEMINPUTS")
Set ws_ItemOutputs = ThisWorkbook.Sheets("ITEMOUTPUTS")
'Get start and end row numbers of test cases from External Test Matrix, and record into array
boo_Empty_Row_Ind = False
'Determine first row (header row) of Test Cases, to determine which row to begin looping from when
'finding Test Cases
int_Test_Case_Start_Row = ws_External_Test_Matrix.Range("A:A").Find(what:="Record", LookIn:=xlValues, LookAt:=xlWhole, After:=ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1)).Row
For i = int_Test_Case_Start_Row To ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1).End(xlUp).Row
'If 0, then row is empty
If (Application.CountA(ws_External_Test_Matrix.Cells(i, 1).EntireRow) = 0) And _
(ws_External_Test_Matrix.Cells(i, 1).EntireRow.Interior.ColorIndex = 1) Then 'If 1, then row is colored black
If boo_Empty_Row_Ind = False And (Not Not arr_Test_Case_Rows) <> 0 Then 'Array is allocated
arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = i - 1
End If
boo_Empty_Row_Ind = True
Else 'Row is NOT empty
'If we previously hit empty row and current row is now non-empty, we have test case to record
If boo_Empty_Row_Ind = True Then
boo_Empty_Row_Ind = False
If (Not Not arr_Test_Case_Rows) = 0 Then 'if 0, then array is unallocated
ReDim arr_Test_Case_Rows(1 To 2, 1 To 1)
Else
ReDim Preserve arr_Test_Case_Rows(1 To 2, 1 To UBound(arr_Test_Case_Rows, 2) + 1)
End If
'arr_Test_Case_Rows(1, X) = start row of test case
'arr_Test_Case_Rows(2, X) = end row of test case
arr_Test_Case_Rows(1, UBound(arr_Test_Case_Rows, 2)) = i
End If
End If
'If I = last row of loop counter
If i = ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1).End(xlUp).Row Then
arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = i ' <-- This line
End If
Next i
The business case context- the broader program that this module is in takes in a sheet of data and reformats it to be uploaded in another program.
The sheet is made up of one header row followed by rows of records of varying size (1 record could be 1 row, all the way up to 7). The blank rows are used to separate when one record ends and another begins.
This particular module is recording where records exist (not blank row) and the line where it breaks is referring to the final non blank row in the sheet.
In this screenshot it is 40 rows, but the actual case is 55.
Here's a slightly different approach using a Collection instead of an array:
Sub Populate_Test_Matrix()
Dim wb As Workbook, extWb As Workbook, wsExtTM As Worksheet, colRecs As Collection
Dim inRecord As Boolean, firstRecordRow, lastRow As Long
Dim rw As Range, rec, startRow As Long
'better for Open_Workbook to return a reference to the workbook, instead of its name...
Set extWb = Open_Workbook(wb.Sheets("Macro_Menu").Range("Test_Case_Matrix_Path").Value)
Set wsExtTM = extWb.Sheets("MATRIX")
firstRecordRow = Application.Match("Record", wsExtTM.Columns("A"), 0)
If IsError(firstRecordRow) Then
MsgBox "'Record' not found in ColA", vbCritical
Exit Sub
End If
Set colRecs = New Collection 'using a collection seems simpler
inRecord = False
Set rw = wsExtTM.Rows(firstRecordRow)
lastRow = wsExtTM.Cells(wsExtTM.Rows.Count, 1).End(xlUp).Row
Do While rw.Row <= lastRow
If Not RowIsEmpty(rw) Then
If Not inRecord Then
startRow = rw.Row 'save the start row
inRecord = True
End If
Else
If inRecord Then 'were we previously in a record?
colRecs.Add Array(startRow, rw.Row - 1)
inRecord = False
End If
End If
Set rw = rw.Offset(1, 0) 'next row
Loop
colRecs.Add Array(startRow, lastRow) 'close the last record
For Each rec In colRecs
Debug.Print "Start row:" & rec(0), "End row:" & rec(1)
Next rec
End Sub
'factored out a bit of logic...
Function RowIsEmpty(rw As Range) As Boolean
'using color not colorindex...
RowIsEmpty = Application.CountA(rw) = 0 And rw.Interior.Color = vbBlack
End Function
I'm searching a range in my sheet for certain values when either of these values is found I want to add the value from column A of that row to an array, only adding values that are not already present in the array. Once the range has been searched, I want to print the arrays to specified cells in the worksheet in 2 different columns.
Here's my code so far:
Dim Ws As Worksheet
Set Ws = Sheets("Sheet1")
Dim Leave() As Variant, Join() As Variant
Dim LastCol As Integer, LastRow As Integer, i As Integer, Z As Integer
Dim J As Long, L As Long
With Sheets("Sheet1")
'Find Last Col
LastCol = Sheets("Sheet1").Cells(3, Columns.Count).End(xlToLeft).Column
'Find last Row
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
LastRow = LastRow - 1
'ReDim Leave(1 To (LastRow - 1), LastCol)
'ReDim Join(1 To (LastRow - 1), LastCol)
For i = 5 To LastCol
For Z = 4 To LastRow
If Sheets("Sheet1").Cells(Z, i).Value = "0" Then
Leave(L) = Ws.Cells(Z, 1).Value
ElseIf Sheets("Sheet1").Cells(Z, i).Value = "-2" Then
Join(J) = Ws.Cells(Z, 1).Value
End If
Next Z
Next i
'Print array
End With
Thanks for any pointers/help in advance!
I believe this procedure accomplishes what you are looking for. You will need to modify the range in which you are searching and the destination sheet information, but the meat of the procedure is here:
Sub abc_Dictionary()
Dim oWS As Worksheet
Dim RangeToSearch As Range
Dim myCell As Range
Dim UniqueDict As Object
Set oWS = Worksheets("Sheet1")
Set RangeToSearch = oWS.Range("B1:B26") 'You can set this dynamically however you wish
Set UniqueDict = CreateObject("Scripting.Dictionary")
'Now we search the range for the given values.
For Each myCell In RangeToSearch
If (myCell.Text = "0" Or myCell.Text = "-2") And Not UniqueDict.exists(oWS.Range("A" & myCell.Row).Text) Then
UniqueDict.Add oWS.Range("A" & myCell.Row).Text, oWS.Range("A" & myCell.Row).Text
End If
Next
'Now we have a dictionary object with the unique values of column a
'So we just iterate and dump into Sheet2
Dim d As Variant
Dim Val As Variant
Dim DestRow As Integer
DestRow = 1 'This is the first row of data we will use on Sheet 2
d = UniqueDict.Items
For Each Val In d
Worksheets("Sheet2").Range("A" & DestRow).Value = Val
DestRow = DestRow + 1
Next
Set UniqueDict = Nothing
Set RangeToSearch = Nothing
Set oWS = Nothing
End Sub
Anybody please help me figure my problem out?
Dim attPresent as Variant ' attpresent()
Set ws = thisworkbook.sheets("Sheet1")
lastrow = ws.cells(Rows.count, 8).end(xlup).row
attPresent = ws.Range("H4:H" & lastrow).Value 'errors if I use Dim attPresent() As Variant
For k = LBound(attPresent, 1) To UBound(attPresent, 1) ' Dim attPresent As Variant'errors if I use
msgbox attpresent(k,1)
Next
This line attPresent = ws.Range("H4:H" & lastrow).Value returns an error if I declare the variable as Dim attPresent() As Variant. Whereas, if declare the variable as Dim attPresent As Variant, this line For k = LBound(attPresent, 1) To UBound(attPresent, 1) errors.
Can anyone please help me clear this out?Thanks
As a good practice, try to remember to use Option Explicit, and also declare all your variables.
When you use Dim attPresent() As Variant to declare you array , and later on you insert values from a Range to your Array with attPresent = .Range("H4:H" & lastrow).Value, it will automatically Redim your array to 2-dimensinal array (1 to Row number, 1 to Column Number).
Option Explicit
Sub RngtoArray()
Dim attPresent() As Variant
Dim ws As Worksheet
Dim lastrow As Long
Dim k As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lastrow = .Cells(.Rows.Count, 8).End(xlUp).Row
attPresent = .Range("H4:H" & lastrow).Value
End With
For k = 1 To UBound(attPresent, 1)
MsgBox attPresent(k, 1)
Next
End Sub
Edit 1: A slightly different approach, in case there is only 1 cell in the Range:
With ws
lastrow = .Cells(.Rows.Count, 8).End(xlUp).Row
' for single column only - create a 1-Dimension array
ReDim attPresent(1 To lastrow - 4 + 1) ' when the Range starts from "H4"
For k = 1 To UBound(attPresent)
attPresent(k) = .Cells(4 + k - 1, "H")
Next k
End With
For k = 1 To UBound(attPresent)
MsgBox attPresent(k)
Next
I tried to separate the stuff that you had already defined but for clarity I thought I'd provide my full code:
Sub test()
Dim lastrow, i As Integer
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")
Dim attPresent() As Variant
lastrow = ws.Cells(Rows.Count, "H").End(xlUp).Row
ReDim attPresent(lastrow - 4)
For i = 4 To lastrow
attPresent(i - 4) = ws.Range("H" & i).Value
Next
msg = Join(attPresent, " ")
MsgBox "The array holds: " & vbNewLine & msg
End Sub
I defined the array without a size to begin with then redefined it to the size it needs to be at a later stage once you know the lastrow (as you started on 4 i deducted 4 from lastrow).
I guessed the msgBox was to test what you had gathered so I created a dump that prints them all into one box but obviously change that if you have a lot of data. xD
To work with arrays I always loop through each individual entry, storing them one at a time. I'm not even sure whether you can dump an entire range into one in one step as I've never even looked into it. Anyway, I hope this solves your problem kupo.
Function RangeToArray(rng As Range)
Dim myArray() As Variant, ws As Worksheet
fr = rng.Row
fc = rng.Column
r = rng.Rows.Count
c = rng.Columns.Count
Set ws = rng.Worksheet
ReDim myArray(r - 1, c - 1)
For i = 0 To r - 1
For j = 0 To c - 1
myArray(i, j) = ws.Cells(fr + i, fc + j).Value2
Next j
Next i
RangeToArray = myArray
End Function
Sub f()
Dim rng As Range, attPresent() As Variant ' attpresent()
Set ws = ThisWorkbook.ActiveSheet 'Sheets("Sheet1")
lastrow = ws.Cells(Rows.Count, 8).End(xlUp).Row
Set rng = ws.Range("H4:H" & lastrow)
attPresent = RangeToArray(rng)
For k = LBound(attPresent, 1) To UBound(attPresent, 1) ' Dim attPresent As Variant'errors if I use
MsgBox attPresent(k, 0)
Next
End Sub
I created a more generic function that you can call in this specific case as well.
I've been searching for an answer to this, but I haven't been able to find anything specific enough to fill the gap in my VBA knowledge.
I'm putting two lists of data into arrays to be compared using a modified version of the code found here
(I'll post it below).
HOWEVER, I don't want to input the whole cell into the array to be compared with the second array. For instance, if the cell in the first sheet says "Company, LLC", I would like to only search "Company". I have some code that does this:
s = rCell.Value
indexofthey = InStr(1, s, ",")
aftercomma = Right(s, Len(s) - indexofthey + 1)
celld = Left(s, Len(s) - Len(aftercomma))
The code I need to somehow work this into (copied from the answer to the question I linked above) is this:
Option Explicit
Private Sub cmdCompare2to1_Click()
Dim sheet1 As Worksheet, sheet2 As Worksheet, sheet3 As Worksheet
Dim lngLastR As Long, lngCnt As Long
Dim var1 As Variant, var2 As Variant, x
Dim rng1 As Range, rng2 As Range
Set sheet1 = Worksheets(1)
Set sheet2 = Worksheets(2)
Set sheet3 = Worksheets(3) ' assumes sheet3 is a blank sheet in your workbook
Application.ScreenUpdating = False
'let's get everything all set up
'sheet3 column headers
sheet3.Range("A1:B1").Value = Array("in1Not2", "in2Not1")
'sheet1 range and fill array
With sheet1
lngLastR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng1 = .Range("A1:A" & lngLastR)
var1 = rng1
End With
'sheet2 range and fill array
With sheet2
lngLastR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng2 = .Range("A1:A" & lngLastR)
var2 = rng2
End With
'first check sheet1 against sheet2
On Error GoTo NoMatch1
For lngCnt = 1 To UBound(var1)
x = Application.WorksheetFunction.Match(var1(lngCnt, 1), rng2, False)
Next
'now check sheet2 against sheet1
On Error GoTo NoMatch2
For lngCnt = 1 To UBound(var2)
x = Application.WorksheetFunction.Match(var2(lngCnt, 1), rng1, False)
Next
On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub
NoMatch1:
sheet3.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = var1(lngCnt, 1)
Resume Next
NoMatch2:
sheet3.Range("B" & sheet3.Rows.Count).End(xlUp).Offset(1) = var2(lngCnt, 1)
Resume Next
End Sub
Assuming you do not want to change the values in your cells you will need to loop through the arrays. You can use a proc like this:
Sub RemoveUnwantedText(ByRef theArray As Variant)
Dim theValue As String
Dim i As Long
Dim indexOfComma As Integer
' array is created from single-column range of cells
' and so has 2 dimensions
For i = LBound(theArray, 1) To UBound(theArray, 1)
theValue = CStr(theArray(i, 1))
indexOfComma = InStr(1, theValue, ",")
If indexOfComma > 0 Then
theValue = Trim(Left(theValue, indexOfComma - 1))
End If
theArray(i, 1) = theValue
Next i
End Sub
Paste this into the same module as your code. In your code, before you do any comparison, add these calls:
RemoveUnwantedText var1
RemoveUnwantedText var2