For some reason, dynamic string created from the specific range is not considering in the array for loops. Below is my code:
Option Explicit
Dim AccrualFile As Workbook, AccrualSht As Worksheet
Dim AccrualFilePath As String
Dim UniqueNames As String, UniqueAccNames As String
Dim Lrows As Long, Lcols As Long
Sub Segregation()
AccrualFilePath = Application.GetOpenFilename(Title:="Please select Accrual Statement")
Set AccrualFile = Workbooks.Open(AccrualFilePath)
Set AccrualSht = AccrualFile.Sheets(1)
Lrows = AccrualSht.Range("B" & Rows.Count).End(xlUp).Row
UniqueNames = Application.WorksheetFunction.TextJoin(""""", """"", True, Application.WorksheetFunction.Unique(AccrualSht.Range("B2:B" & Lrows)))
UniqueAccNames = """""" & UniqueNames & """"""
Dim i As Long
Dim myarr() As Variant
myarr = Array(UniqueAccNames)
For i = LBound(myarr) To UBound(myarr)
Debug.Print myarr(i)
Next
End Sub
Appreciate your help!!
Thank you.
WorksheetFunction.Unique returns a (2D)1 array when passed a Range.
myarr = WorksheetFunction.Unique(AccrualSht.Range("B2:B" & Lrows))
Dim i As Long, j As Long
For i = LBound(myarr, 1) to Ubound(myarr, 1)
For j = Lbound(myarr, 2) to Ubound(myarr, 2)
Debug.Print myarr(i, j)
Next
Next
1 With some exceptions, including:
When the output is a single element, it returns a 1D array.
Related
I have been trying to match Date with week number i.e. ("B1:F1")
then date with Year-month i.e. ("A2:A500")
If matches then copy the value from this table that i have highlighted according to the date which is available in code where week is 2 and month is May-2021. Can someone please help me to achieve this.
There are multiple dates which i need to iterate with this table to get different values according to weeks and Year-Months.
Your help will be much appreciated.
Sub findMatchingRecords()
Dim rng1 As Range
Dim rng2 As Range
Dim ws As Worksheet
Dim getdate As String
Dim GetWeek As String
Set ws = Worksheets("Sheet1")
getdate = ws.Range("N1").Value
GetWeek = Int((Day(getdate) + 6) / 7)
Set rng1 = ws.Range("B1:F1")
Set rng2 = ws.Range("A2:A500")
For Each rng1cell In rng1
For Each rng2cell In rng2
If rng1cell = GetWeek And rng2cell = Format(getdate, "yyyy-mmm") Then
'Copy value and paste into Sheet1.Range("M2")
End If
Next rng1cell
Next rng2cell
End Sub
Here are the dates which needs to match with table and get relevant the value.
5/13/2021
5/16/2021
5/19/2021
5/22/2021
5/25/2021
5/28/2021
5/31/2021
6/3/2021
6/6/2021
6/9/2021
6/12/2021
6/15/2021
6/18/2021
6/21/2021
6/24/2021
Non-VBA Method
One way this could be done without using VBA is with a INDEX/MATCH formula.
The following formula assumes the data is in B2:F500, the month/years are in A2:A500, the weeks in B1:F1 and the dates to look for are in column N, all on the same sheet Sheet1.
=INDEX($B$2:$F$13,MATCH(TEXT(N1,"yyyy-mmm"),Sheet1!$A$2:$A$13,0),MATCH(INT((DAY(N1)+6)/7),Sheet1!$B$1:$F$1,0))
VBA Method
If you want VBA to do this here's one way.
Option Explicit
Sub findMatchingRecords()
Dim ws As Worksheet
Dim rngData As Range
Dim rngDates As Range
Dim arrData As Variant
Dim arrDates As Variant
Dim arrYearMonth As Variant
Dim arrValues As Variant
Dim arrWeeks As Variant
Dim Res As Variant
Dim idxCol As Long
Dim idxDate As Long
Dim idxRow As Long
Dim wk As Long
Set ws = Sheets("Sheet1")
With ws
Set rngData = .Range("A1").CurrentRegion
Set rngDates = .Range("N1", .Range("N" & Rows.Count).End(xlUp))
End With
With rngData
arrData = rngData.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
arrYearMonth = .Columns(1).Offset(1).Resize(.Rows.Count - 1)
arrWeeks = .Rows(1).Offset(, 1).Resize(, .Columns.Count - 1)
End With
arrDates = rngDates.Value
ReDim arrValues(1 To UBound(arrDates, 1), 1 To 1)
For idxDate = LBound(arrDates, 1) To UBound(arrDates, 1)
idxRow = 0
idxCol = 0
Res = Application.Match(Format(arrDates(idxDate, 1), "yyyy-mmm"), arrYearMonth, 0)
If Not IsError(Res) Then
idxRow = Res
wk = Int((Day(arrDates(idxDate, 1)) + 6) / 7)
Res = Application.Match(wk, arrWeeks, 0)
If Not IsError(Res) Then
idxCol = Res
End If
End If
If idxRow <> 0 And idxCol <> 0 Then
arrValues(idxDate, 1) = arrData(idxRow, idxCol)
End If
Next idxDate
rngDates.Offset(, 1).Value = arrValues
End Sub
Please, test the next code:
Sub MatchDate_WeekNo()
Dim sh As Worksheet, lastR As Long, arr, arrN, arrfin, i As Long, strDate As String
Dim weekN As Long, arrRow, arrCol, iCol As Variant, iRow As Variant, lastRN As Long
Set sh = Worksheets("Sheet1")
lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
lastRN = sh.Range("N" & sh.Rows.Count).End(xlUp).Row
arr = sh.Range("A1:F" & lastR).Value
arrRow = Application.Index(arr, 1, 0)
arrCol = Application.Transpose(Application.Index(arr, 0, 1))
arrN = sh.Range("N2:N" & lastRN).Value2
ReDim arrfin(1 To UBound(arrN), 1 To 1)
For i = 1 To UBound(arrN)
strDate = StringFromDate(CDate(arrN(i, 1)))
weekN = Int((Day(arrN(i, 1)) + 6) / 7)
iCol = Application.Match(weekN, arrRow, 0)
iRow = Application.Match(strDate, arrCol, 0)
If IsNumeric(iCol) And IsNumeric(iRow) Then
arrfin(i, 1) = arr(iRow, iCol)
End If
Next i
'drop the final array content:
sh.Range("O2").Resize(UBound(arrfin), 1).Value = arrfin
End Sub
Function StringFromDate(d As Date) As String
Dim arrM
Const strMonths As String = "Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec"
arrM = Split(strMonths, ",")
StringFromDate = Year(d) & "-" & Application.Index(arrM, Month(d))
End Function
Format(arrDates(idxDate, 1), "yyyy-mmm") does not return the month in case of localization different then English type and only that's why I am using a function...
with the given code I am trying hard incorporate the Filldown approach until the last row but at present whatever I do only fills row number 1:
Sub FillDownApproach()
Dim destinationWs As Worksheet
Dim destinationLastRow As Long
Set destinationWs = ThisWorkbook.Worksheets("Main Board")
destinationLastRow = destinationWs.Range("A" & Rows.Count).End(xlUp).Row
RetVal = destinationWs.Evaluate("INDEX('MyData'!$E:$E,MATCH(1,($A2='MyData'!$B:$B)*(""MyItem""='MyData'!$D:$D),0))")
destinationWs.Range("C2").Value = RetVal
destinationWs.Range("C3: " & "C" & destinationLastRow).FillDown
End Sub
Any suggestion that could point towards the right direction.
Thanks
You cannot do what you want without looping. And Looping ranges is slow.
Instead load Variant arrays and loop them.
Sub FillDownApproach()
Dim destinationWs As Worksheet
Set destinationWs = ThisWorkbook.Worksheets("Main Board")
Dim destinationLastRow As Long
destinationLastRow = destinationWs.Range("A" & Rows.Count).End(xlUp).Row
Dim lkpArr As Variant
lkpArr = destinationWs.Range("A2:A" & destinationLastRow).Value
With Worksheets("MyData")
Dim retval As Variant
retval = Intersect(.Range("E:E"), .UsedRange)
Dim mtch As Variant
mtch = Intersect(.Range("B:D"), .UsedRange)
End With
Dim outArr As Variant
ReDim outArr(1 To UBound(lkpArr, 1), 1 To 1)
Dim i As Long
For i = 1 To UBound(lkpArr, 1)
Dim j As Long
For j = 1 To UBound(retval, 1)
If mtch(j, 3) = "MyItem" Then
If mtch(j, 1) = lkpArr(i, 1) Then
outArr(i, 1) = retval(j, 1)
Exit For
End If
End If
Next j
Next i
destinationWs.Range("C2").Resize(UBound(outArr, 1), 1).Value = outArr
End Sub
Im trying to export 4 columns into one .csv file. Therefore I want to combine all 4 columns into one range and export this range. Somehow rng only has one column. Why?
Set rng = Application.Union(Range("Berechnung!$A$10811:$A$39611"),Range("Berechnung!$BA$10811:$BC$39611"))
Thank you!
Your use of UNION is fine, but now you must account for the fact that the range has more than one area.
This answer uses YOUR code and extends it to work with the areas in the disjointed range.
Set rng = Union(Range("Berechnung!$A$10811:$A$39611"),Range("Berechnung!$BA$10811:$BC$39611"))
For i = 1 To rng.Rows.Count
For a = 1 To rng.Areas.Count
For j = 1 To rng.Areas(a).Columns.Count
str = str & rng.Areas(a)(i, j).Value & " ,"
Next
Next
Print #fNum, Left(str, Len(str) - 2)
str = ""
Next
You have a disjoint range. It is not easy to count the number of columns in this case. For example:
Sub dural()
Dim r1 As Range, r2 As Range, rTot As Range, Column As Variant
Dim kount As Long
Set r1 = Range("A1:A10")
Set r2 = Range("D1:E10")
Set rTot = Union(r1, r2)
MsgBox rTot.Columns.Count
kount = 0
For Each Column In rTot.Columns
kount = kount + 1
Next Column
MsgBox kount
End Sub
The first MsgBox will report 1, the second MsgBox will report 3.
Option Explicit
Sub MyExportCsv()
Const START_ROW = 10811
Const END_ROW = 39611
Const CSV_FILE = "export.csv"
Dim ws As Worksheet, str As String, i As Long
Dim rng As Range, cell As Range, count As Long
Dim oFSO As Object, oFS As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.CreateTextFile(CSV_FILE)
Set ws = ThisWorkbook.Sheets("Sheet1")
For i = START_ROW To END_ROW
str = ws.Range("A" & i)
Set rng = ws.Range("BA" & i & ":BC" & i)
For Each cell In rng
str = str & " ," & cell.Value
Next
oFS.writeline str
count = count + 1
Next
oFS.Close
MsgBox count & " records written to " & CSV_FILE, vbInformation, "Finished"
End Sub
You can use a procedure that creates an array and converts it to csv as a parameter.
Sub ExportSheetsToCSV()
Dim Ws As Worksheet
Dim xcsvFile As String
Dim vDB1 As Variant, vDB2 As Variant, vDB() As Variant
Dim r As Long, i As Long, j As Integer
Set Ws = ActiveSheet
xcsvFile = CurDir & "\" & Ws.Name & ".csv"
vDB1 = Range("Berechnung!$A$10811:$A$39611")
vDB2 = Range("Berechnung!$BA$10811:$BC$39611")
r = UBound(vDB1, 1)
ReDim vDB(1 To r, 1 To 4)
For i = 1 To r
vDB(i, 1) = vDB1(i, 1)
For j = 1 To 3
vDB(i, j + 1) = vDB2(i, j)
Next j
Next i
TransToCSV xcsvFile, vDB
MsgBox ("Files Saved Successfully")
End Sub
Sub TransToCSV(myfile As String, vDB As Variant)
Dim vR() As String, vTxt()
Dim i As Long, n As Long, j As Integer
Dim objStream
Dim strTxt As String
Set objStream = CreateObject("ADODB.Stream")
For i = 1 To UBound(vDB, 1)
n = n + 1
ReDim vR(1 To UBound(vDB, 2))
For j = 1 To UBound(vDB, 2)
vR(j) = vDB(i, j)
Next j
ReDim Preserve vTxt(1 To n)
vTxt(n) = Join(vR, ",")
Next i
strTxt = Join(vTxt, vbCrLf)
With objStream
.Open
.WriteText strTxt
.SaveToFile myfile, 2
.Close
End With
Set objStream = Nothing
End Sub
I am trying to get unique values from dynamic F column and store it in an array. I am getting "Object Required error for my code while setting Selection variable to a dynamic range. Please help.
Sub UniqueFilter()
Dim tmp As String
Dim arr() As String
Dim Selection As Range
Dim lrow As Long
Dim str As String
Dim cell As Range
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("14Feb19")
sht.Activate
'Set Selection = sht.Range(sht.Cells(1, 6), sht.Cells(Rows.Count, 6).End (xlUp)).Select
lrow = shData.Range("F" & Rows.Count).End(xlUp).Row
Set Selection = sht.Range("F2:F" & lrow).Select
If Not Selection Is Nothing Then
For Each cell In Selection
If (cell <> "") And (InStr(tmp, cell) = 0) Then
tmp = tmp & cell & "|"
End If
Next cell
End If
If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
arr = Split(tmp, "|")
End Sub
You can achieve your goal without having to use Selection at all.
Just copy the range content and transpose it into an array:
Sub UniqueFilter()
Dim arr() As String
Dim tmp As Variant
Dim lrow As Long
Dim sht As Worksheet
Dim index As Integer
Dim count As Integer
Set sht = ThisWorkbook.Worksheets("14Feb19")
sht.Activate
lrow = sht.Range("F" & Rows.count).End(xlUp).Row
'Copying and trasposing selected Range
tmp = Application.Transpose(sht.Range("F2:F" & lrow).Value)
'Cleaning from temp array all empty values
count = 1
For index = 1 To UBound(tmp, 1) - LBound(tmp, 1) + 1
ReDim Preserve arr(1 To count)
If tmp(index) <> "" Then
arr(count) = tmp(index)
count = count + 1
End If
Next
End Sub
(special thanks to #Nathan_Sav, who helped simplifying the code)
I've written a near-working script to search for a list of words in column B within a larger list in column A.
Sub QualifierArray()
Sub QualifierArray()
Dim List As Worksheet
Set List = Sheets("List")
Dim lastRow As Long
lastRow = (List.Cells(Rows.Count, 1).End(xlUp).Row) 'removed +1
Dim listColumn As Variant
listColumn = List.Range("A1:A" & lastRow)
Dim outputArray As Variant
Dim intQualifier As Long
Dim lastQualifier As Range
ReDim outputArray(1 To lastRow)
Dim i As Long
Dim j As Long
Dim index As Long
index = 1
intQualifier = Range("B" & Rows.Count).End(xlUp).Row
For j = 1 To intQualifier
For i = 1 To lastRow
Set rngQualifier = Range("B" & j)
If InStr(listColumn(i, 1), rngQualifier) > 0 Or InStr(listColumn(i, 1), "[") > 0 Then 'changed = to >
outputArray(index) = listColumn(i, 1)
index = index + 1
End If
Next
Next
End Sub
However, I'm getting a "subscript out of range" for the outputArray. It seems that index has increased to be more than lastRow, which is causing the error. I've tried a variety of fixes, like putting an extra clause like is not empty but to no avail. Does anyone have any suggestions as to what's causing the error? One clue is that removing the Or InStr(listColumn(i, 1), "[") = 0 part` lets the code perfectly (without this clause, of course). Am I getting close to a solution? It feels as if it's not far from here....
Thanks in advance!
try with below code
Sub QualifierArray()
Dim List As Worksheet
Set List = Sheets("List")
Dim lastRow As Long
lastRow = (List.Cells(Rows.Count, 1).End(xlUp).Row) 'removed +1
Dim listColumn As Variant
listColumn = List.Range("A1:A" & lastRow)
Dim outputArray As Variant
Dim intQualifier As Long
Dim lastQualifier As Range
ReDim outputArray(1 To lastRow)
Dim i As Long
Dim j As Long
Dim index As Long
index = 1
intQualifier = Range("B" & Rows.Count).End(xlUp).Row
For j = 1 To intQualifier
For i = 1 To lastRow
Set rngQualifier = Range("B" & j)
If InStr(listColumn(i, 1), rngQualifier) > 0 Or InStr(listColumn(i, 1), "[") > 0 Then 'changed = to >
outputArray(index) = listColumn(i, 1)
index = index + 1
End If
Next
Next
End Sub
Note: Changes made marked in comment