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
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.
I have a vba macros that checks to see if there are duplicates in Column A & checks to see if there is a certain value in Column B but was wondering if there was a way to convert it to using with an array. The current code works great but I ran into a file that has over 153,000 rows in it & it takes the macros hours to run.
I can get it to find duplicates in Column A with an Array but can not figure out how to also check to see if it matches a certain value in Column B.
This is what I want it to do:
If match:
If not a match:
Here is the code I have right now to find duplicates not using an array:
Dim cell As Range
Dim wbook As Workbook
Dim wsheet As Worksheet
Dim sname As Range
Dim cname As Range
Dim rngA As Range
Dim dupA As Range
Dim dupB As Range
Dim strName As String
Set wbook = ActiveWorkbook 'Current Workbook
Set wsheet = Sheets("OFA_CP_OUT_202112_Without_Match") 'Worksheet Name
Set sname = Range("A2:H2426") 'Range for sorting and aligning columns A:H
Set cname = Sheets("OFA_CP_OUT_202112_Without_Match").Range("F2:F2426") 'Sheet Name & Range to format currency
Set rngA = Range("A2:A2426") 'Range to change column A to uppercase & find if a cell contains an A, B or S
Set dupA = wsheet.Range("A2:A2426") 'Range to find duplicates in column A
Set dupB = wsheet.Range("B2:B2426") 'Range to find year & month in column B (ex: 202112)
strName = "202112" 'year & month to search for in column B
'Looks for duplicates and highlights them yellow in column A & column B
For Each cell In dupA
If WorksheetFunction.CountIfs(dupA, "=" & cell.Value, dupB, "=" & cell.Offset(0, 1).Value) > 1 Then
cell.Interior.ColorIndex = 6
cell.Offset(0, 1).Interior.ColorIndex = 6
End If
Next cell
Here is the code that I got working using an array to find duplicates:
Sub Dupes()
Dim Ws As Worksheet
Dim LastRow As Long, i As Long, j As Long, DupCounter As Long, DupPos As Long
Dim MatNo As String
Dim Found As Boolean
Dim ArrDuplicates() As Variant 'Declare dynamic array
Set Ws = ThisWorkbook.Sheets(1)
'Redimennsion/change size of declared array
ReDim ArrDuplicates(1 To 2, 1 To 1)
DupCounter = 1
With Ws
'find last row with data in column "A"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'Loop all rows from 1 to last
For i = 1 To LastRow
'reset variables for each loop
Found = False
DupPos = 0
MatNo = .Cells(i, 1)
'Search array with previous data and look for duplicates
For j = LBound(ArrDuplicates(), 2) To UBound(ArrDuplicates(), 2)
'If material number currently checked found in array
If MatNo = ArrDuplicates(1, j) Then
'remember position of source data in array (first occurence
'of material number)
DupPos = j
'set "Found" marker
Found = True
'leave loop
Exit For
End If
Next j
'if no duplicate found
If Not Found Then
'redimension array. "Preserve" keyword added to keep values
'already existing in array
ReDim Preserve ArrDuplicates(1 To 2, 1 To DupCounter)
'insert new data to array ((first occurance of material number)
ArrDuplicates(1, DupCounter) = MatNo
DupCounter = DupCounter + 1 'increase counter used to redimension array
Else 'if material number found in array
'change font color
.Cells(i, 1).Font.Color = vbRed
End If
Next i
End With
End Sub
Thanks for your help!
This should be faster:
Sub FlagDups()
Dim wb As Workbook, wsheet As Worksheet
Dim dupA As Range, arrA, dupB As Range, arrB
Dim dict As Object, i As Long, k, rng As Range
Set dict = CreateObject("scripting.dictionary")
Set wb = ActiveWorkbook
Set wsheet = wb.Worksheets("OFA_CP_OUT_202112_Without_Match")
Set dict = CreateObject("scripting.dictionary")
Set dupA = wsheet.Range("A2:A2426") 'Range to find duplicates in column A
Set dupB = wsheet.Range("B2:B2426") 'Range to find year & month in column B (ex: 202112)
arrA = dupA.Value 'read all the data
arrB = dupB.Value
wsheet.Range("A1:B10000").Interior.ColorIndex = xlNone 'clear any existing fill
For i = LBound(arrA) To UBound(arrA) 'loop over the data arrays
k = arrA(i, 1) & Chr(0) & arrB(i, 1) 'composite key from A, B
If Not dict.exists(k) Then
dict.Add k, i 'novel pair of values: store row index
Else
If dict(k) > 0 Then 'need to process store row index?
addCell rng, dupA.Cells(dict(k)) 'collect the first instance of this pair
addCell rng, dupB.Cells(dict(k))
dict(k) = 0 'flag as collected
End If
addCell rng, dupA.Cells(i) 'collect current instance
addCell rng, dupB.Cells(i)
End If
Next i
If Not rng Is Nothing Then rng.Interior.Color = vbYellow 'any cells to color?
End Sub
'build a range by adding rngAdd to rngTot
Sub addCell(rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub
Hey I am a trainee as an IT-Specialist and my trainer gave me a task to complete a macro for excel. (I don't know anything about VBA)
I have to check the cells in a column for the value 1. If there is a 1 I need to store that value in a array.
That's what I did till now.
Sub test()
Dim sht As Worksheet
Dim LastColumn As Long
Dim LastRow As Long
Dim MyArray() As Single
Set sht = ThisWorkbook.Worksheets("Tabelle1")
LastRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row
MsgBox LastRow
MsgBox Join(MyArray)
End Sub
Sub createArray(x As Variant)
Dim sht As Worksheet
Dim LastRow As Long
Dim tempArray() As String
Dim rowVal As String
Dim MyArray() As Single
Dim i As Integer
Dim j As Integer
Dim rang As Range
Dim arrayEntry As String
Set sht = ThisWorkbook.Worksheets("Tabelle1")
Set rang = sht.Range("A:A") ' // SET RANGE TO LOOK FOR VALUES
LastRow = rang.SpecialCells(xlCellTypeLastCell).Row
arrayEntry = ""
For i = 1 To LastRow
If sht.Cells(i, 1).Value = x Then ' // (i, 1) <---- '1' references column A -
change to numerical column that you want to loop through
If arrayEntry = "" Then
arrayEntry = x
rowVal = i
Else
arrayEntry = arrayEntry & "," & x
rowVal = rowVal & "," & i
End If
End If
Next i
tempArray = Split(arrayEntry, ",")
ReDim MyArray(UBound(tempArray))
For j = 0 To UBound(tempArray)
MyArray(j) = CInt(tempArray(j))
Next j
Erase tempArray
MsgBox LastRow
MsgBox arrayEntry
MsgBox rowVal
MsgBox (UBound(MyArray) + 1)
End Sub
I am unsure if you wanted the value '1' in the array or the row it appears on, swap x with i if you wanted the row number.
Sub TESTFORMULA()
createArray (1)
End Sub
I have a column with different values. I have to select only unique values from the column and put in an array.
I am using following code for the same but it puts unique values in another column rather array.
Sub GetUniqueSections()
Dim d As Object, c As Variant, i As Long, lastRow As Long
Dim a(8) As String
Dim j
Set d = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("C2:C" & lastRow)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Range("R2").Resize(d.Count) = Application.Transpose(d.Keys)
End Sub
In the code below, UniqueValueArrayFromRange replaces your GetUniqueSections using the same technique with a Scripting.Dictionary. You can substitute "A1:A14" with whatever you need and the output array will be in arr:
Option Explicit
Sub Test()
Dim rng As Range
Dim arr As Variant
Dim i As Integer
' pass range values to function for unique values
Set rng = Sheet1.Range("A1:A14")
arr = UniqueValueArrayFromRange(rng)
' test return values
For i = LBound(arr) To UBound(arr)
Debug.Print arr(i)
Next i
End Sub
Function UniqueValueArrayFromRange(ByRef rngSource As Range) As Variant
Dim dic As Object
Dim rngCell As Range
' create dictionary and only add new values
Set dic = CreateObject("Scripting.Dictionary")
For Each rngCell In rngSource
If Not dic.Exists(rngCell.Value) Then
dic.Add rngCell.Value, 1
End If
Next rngCell
' return key collection as array
UniqueValueArrayFromRange = dic.Keys
End Function
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