This is posted by Dammer15 and this is what I'm looking for. However I need it to loop through the entire column. I would ask there directly but I can not comment yet.
Dim My_Number As String
Dim i As Integer
My_Number = Range("AJ")
For i = 1 To Len(My_Number) - 1
If InStr(1, My_Number, "0") = 1 Then
My_Number = Right(My_Number, Len(My_Number) - 1)
Else
Range("AJ") = My_Number
Exit For
End If
Next
You will need to iterate through each value. I would recommend uploading the whole range into an array and then looping through that instead:
Sub foo()
Dim rng As Range
Dim i As Long, j As Long
Dim arr() As Variant
Dim lastRow As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "AJ").End(xlUp).Row
Set rng = .Range("AJ1", .Cells(lastRow, "AJ"))
arr = rng.Value
For i = LBound(arr, 1) To UBound(arr, 1)
My_Number = arr(i, 1)
For j = 1 To Len(arr(i, 1)) - 1
If Mid(arr(i, 1), j, 1) <> 0 Then
arr(i, 1) = Right(arr(i, 1), Len(arr(i, 1)) - (j - 1))
Exit For
End If
Next j
Next i
rng.Value = arr
End With
End Sub
You could use a regex to match the lead 0s instead of the bulky replace function you currently have:
Sub TestRe()
Dim LastCell As Range: Set LastCell = ActiveSheet.Columns("AJ").Find("*", SearchDirection:=xlPrevious)
Dim Rng As Range: Set Rng = ActiveSheet.Range("AJ1", LastCell)
Dim Cell As Range: For Each Cell In Rng
Cell.Value = RemoveLead0s(Cell.Value)
Next Cell
End Sub
Function RemoveLead0s(AlphaNum As String) As String
RemoveLead0s = AlphaNum
' RegExp requires "Microsoft VBScript Regular Expressions 5.5" reference
Dim RegEx As New RegExp
With RegEx
.Pattern = "^0*"
If .test(AlphaNum) Then RemoveLead0s = .Replace(AlphaNum, "")
End With
End Function
Related
I'm new to VBA.
I have this formula in Excel in a new column (U) for each row, but takes too long and crashes:
=IF(COUNTIFS($E:$E,E2,$A:$A,"<>"&A2)>0,"Yes","No")
Is there a way to make this in VBA?
Thanks
Based on my understanding of your Excel formula. You are trying to put "Yes" in column U for each row where its value in column E is found elsewhere in Column E, but only if the Column A value is different.
Here is how you would do that in VBA:
Sub Example()
Dim Sh As Worksheet
Set Sh = ActiveSheet
Dim LastRow As Integer
LastRow = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row
Dim TargetRange As Range
Set TargetRange = Sh.Range("A2:E" & LastRow)
Dim vArr() As Variant
vArr = TargetRange.Value
Dim ColU() As Variant
ReDim ColU(1 To UBound(vArr, 1), 1 To 1)
Dim i As Long
For i = 1 To UBound(vArr, 1)
ColU(i, 1) = "No"
Dim j As Long
For j = 1 To UBound(vArr, 1)
If vArr(i, 5) = vArr(j, 5) And vArr(i, 1) <> vArr(j, 1) Then
ColU(i, 1) = "Yes"
Exit For
End If
Next
Next
Sh.Range("U2").Resize(UBound(vArr, 1)).Value = ColU
End Sub
I first take the values of range A:E into an array. Then I loop through the array checking if my statement is true. If true, "Yes", otherwise default to "No". And then I output the answers to column U.
The downside to this approach is that it is n^2 number of iterations, as I loop through the array for each row of the array. It will be inevitably slow with a very large dataset.
An improvement suggested by #ChrisNeilsen was to start the inner loop from i, cutting the iterations by half. To encorporate this idea, I set up the ColU default values in its own loop first, and then when finding duplicates, I can set both of the duplicates to "Yes" at the same time.
Sub Example()
Dim Sh As Worksheet
Set Sh = ActiveSheet
Dim LastRow As Integer
LastRow = Sh.Cells(Sh.Rows.Count, "E").End(xlUp).Row
Dim TargetRange As Range
Set TargetRange = Sh.Range("A2:E" & LastRow)
Dim vArr() As Variant
vArr = TargetRange.Value
Dim ColU() As Variant
ReDim ColU(1 To UBound(vArr, 1), 1 To 1)
Dim i As Long
For i = 1 To UBound(vArr, 1)
ColU(i, 1) = "No"
Next
For i = 1 To UBound(vArr, 1)
Dim j As Long
For j = i To UBound(vArr, 1)
If vArr(i, 5) = vArr(j, 5) And vArr(i, 1) <> vArr(j, 1) Then
ColU(i, 1) = "Yes"
ColU(j, 1) = "Yes"
Exit For
End If
Next
Next
Sh.Range("U2").Resize(UBound(vArr, 1)).Value = ColU
End Sub
Rather than a double loop (which runs in order n^2) another approach that uses a single loop would be to use a lookup instead of the inner loop (this runs in order n, although a little more complex on each iteration).
Something like
Sub Example2()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, 5).End(xlUp).Row
Dim TargetRange As Range
Set TargetRange = ws.Range(ws.Cells(2, 1), ws.Cells(LastRow, 5))
Dim vArr() As Variant
vArr = TargetRange.Value2
Dim ColU() As Variant
ReDim ColU(1 To UBound(vArr, 1), 1 To 1)
Dim i As Long
Dim j As Long
Dim rE As Range
Set rE = ws.Range(ws.Cells(2, 5), ws.Cells(LastRow, 5))
ColU(UBound(vArr, 1), 1) = "No"
For i = 1 To UBound(vArr, 1) - 1
j = 0
On Error Resume Next
j = Application.WorksheetFunction.XMatch(vArr(i, 5), rE.Offset(i, 0), 0, 1)
On Error GoTo 0
ColU(i, 1) = "No"
If j > 0 Then
If vArr(i, 1) <> vArr(j + i, 1) Then
ColU(i, 1) = "Yes"
ColU(j + i, 1) = "Yes"
End If
End If
Next
ws.Range("U2").Resize(UBound(vArr, 1)).Value = ColU
End Sub
On my hardware, a arbitary sample data set ran
Rows
double loop
this code
100
0.015
0.01
1000
0.17
0.03
10000
11.9
0.33
50000
285.0
2.0
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...
I have created a function that retrieves a Range based on column name. Here is my code:
Sub sep_Filter()
Dim zip_rng As String
With Sheet2
zip_rng = getColRangeFunction("postalcode")
If Len(Range(zip_rng)) > 5 Then
Range(zip_rng).Interior.Color = RGB(255, 0, 0)
Range(zip_rng).Select
Else
Range(zip_rng).Interior.Color = xlNone
End If
End With
End Sub
Sheet2 Input Column D
Sheet2 Output Column D
Sheet3 Output Column D
088762598
088762598
06610-5000
06610-5000
330161898
330161898
970152880
970152880
112202570
112202570
127420800
127420800
062262040
062262040
07631
07631
10029
10029
11803
11803
99336
99336
EDIT I misunderstood what you were asking, I updated my answer to be tied to your question.
Here's a basic approach that will do what you're asking. It skips row one.
Sub onlyfirst5()
Const pRange As String = "D1"
Dim ws As Worksheet
Set ws = ActiveSheet
Dim crng As Range, cValues()
Set crng = Intersect(ws.UsedRange.Offset(1, 0), ws.UsedRange, ws.Range("D:D"))
cValues = crng.Value
Dim i As Long, j As Long
For i = LBound(cValues) To UBound(cValues)
For j = LBound(cValues, 2) To UBound(cValues, 2)
cValues(i, j) = Left(cValues(i, j), 5)
Next j
Next i
'for same sheet different column
ws.Range("F2").Resize(UBound(cValues), UBound(cValues, 2)) = Application.Transpose(cValues)
'different sheet
Sheets("Sheet2").Range("F2").Resize(UBound(cValues), UBound(cValues, 2)) = Application.Transpose(cValues)
'different file
Workbooks("Zip Code Question.xlsb").Sheets("Sheet3").Range("F2").Resize(UBound(cValues), UBound(cValues, 2)) = Application.Transpose(cValues)
End Sub
Copy Entire Rows If Criteria Met
Option Explicit
Sub Postal5()
' Define constants.
Const srcName As String = "Sheet2"
Const srcFirst As String = "D2"
Const dstName As String = "Sheet3"
Const dstFirst As String = "A2" ' do not change the 'A' (entire row).
Const pLen As Long = 5
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define Source Range.
Dim LastRow As Long
Dim srg As Range
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1)
End With
' 'Combine' critical cells into a range.
Dim brg As Range ' Built Range
Dim cel As Range ' Current Cell Range
For Each cel In srg.Cells
If Len(cel.Value) > pLen Then
If brg Is Nothing Then
Set brg = cel
Else
Set brg = Union(brg, cel)
End If
End If
Next cel
If brg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
' Copy and delete critical rows of Source Range.
With wb.Worksheets(dstName).Range(dstFirst)
.Resize(.Worksheet.Rows.Count - .Row + 1, _
.Worksheet.Columns.Count).Clear
Set brg = brg.EntireRow ' 'Convert' cells into rows.
brg.Copy .Offset ' Copy. 'Offset' because range is in 'With'.
brg.Delete ' Delete.
End With
Application.ScreenUpdating = False
End Sub
Text the next code, please. It uses arrays and it should be very fast for a big range:
Sub testSplitZiPCodeStrings()
Dim sh2 As Worksheet, sh3 As Worksheet, lastR As Long
Dim i As Long, arr, arrZip, arrNoZip, kZ As Long, kN As Long
Set sh2 = ActiveSheet ' Worksheets("Sheet2")
Set sh3 = sh2.Next ' Worksheets("Sheet3")
lastR = sh2.Range("D" & sh2.Rows.count).End(xlUp).row 'last row
arr = sh2.Range("D2:D" & lastR).Value 'put the range in an array
ReDim arrZip(UBound(arr) - 1) 'redim the array to surely have place for all elements
ReDim arrNoZip(UBound(arr) - 1) 'redim the array to surely have place for all elements
For i = 1 To UBound(arr) ' iterate between the array elements
If Len(arr(i, 1)) = 5 Then
arrZip(kZ) = arr(i, 1): kZ = kZ + 1
Else
arrNoZip(kN) = arr(i, 1): kN = kN + 1
End If
Next i
ReDim Preserve arrZip(kZ - 1) 'keep only the array elements having values
ReDim Preserve arrZip(kN - 1) 'keep only the array elements having values
sh2.Range("D2:D" & lastR).Clear 'Clear the initial range
'Drop the Zip array content at once:
sh2.Range("D2").Resize(UBound(arrZip), 1).Value = Application.Transpose(arrZip)
'Drop the NoZip array content at once:
sh3.Range("D2").Resize(UBound(arrNoZip), 1).Value = Application.Transpose(arrNoZip)
End Sub
Here's 2 samples. The first one is more intuitive and uses ranges. The second one is less intuitive but faster by using arrays.
Simple but Slower:
'The easy way, but can be slow if you have lots of zip codes
Sub TrimRange()
Dim InputWorksheet As Worksheet, OutputWorksheet As Worksheet
Dim RangeInput As Range, RangeOutput As Range, Column As Range
Dim HeaderRow As Integer, ColumnNumber As Integer, LastRow As Integer, i As Integer
Dim OutputColumn As Range
Dim ColumnFound As Boolean
Dim fullzipcode As String
Set InputWorksheet = Worksheets("Sheet2")
Set OutputWorksheet = Worksheets("Sheet3")
HeaderRow = 1
'Get Input and Output Range
ColumnNumber = 0
ColumnFound = False
For Each Column In InputWorksheet.Columns
ColumnNumber = ColumnNumber + 1
If Column.Cells(HeaderRow, 1) = "postalcode" Then
LastRow = Column.End(xlDown).Row
'I assume the Output column will be in the same position as the input column
Set OutputColumn = OutputWorksheet.Columns(ColumnNumber)
'If OutputColumn is always in Column 'D' then replace previous line with:
'Set OutputColumn = OutputWorksheet.Columns(4)
Set RangeInput = InputWorksheet.Range(Column.Cells(HeaderRow + 1, 1), Column.Cells(LastRow, 1))
Set RangeOutput = OutputWorksheet.Range(OutputColumn.Cells(HeaderRow + 1, 1), OutputColumn.Cells(LastRow, 1))
ColumnFound = True
Exit For
End If
Next
If ColumnFound Then
'Initialize Interior color to nothing
'and remove values from output column
RangeInput.Interior.ColorIndex = 0
RangeOutput.ClearContents
'Change values and formatting
For i = 1 To RangeInput.Rows.Count
fullzipcode = RangeInput.Cells(i, 1).Value
If Len(fullzipcode) > 5 Then
RangeInput.Cells(i, 1).Interior.Color = RGB(255, 0, 0)
RangeInput.Cells(i, 1).Value = Left(fullzipcode, 5)
End If
RangeOutput.Cells(i, 1).Value = fullzipcode
Next
End If
End Sub
Faster but Less Intuitive
'The harder way, but faster
Sub TrimRange2()
Dim InputWorksheet As Worksheet, OutputWorksheet As Worksheet
Dim RangeInput As Range, RangeOutput As Range, Column As Range
Dim HeaderRow As Integer, ColumnNumber As Integer, LastRow As Integer, i As Integer
Dim InputValues() As Variant, OutputValues() As Variant
Dim OutputColumn As Range
Dim ColumnFound As Boolean
Dim fullzipcode As String
Set InputWorksheet = Worksheets("Sheet2")
Set OutputWorksheet = Worksheets("Sheet3")
HeaderRow = 1
'Get Input and Output Range
ColumnNumber = 0
ColumnFound = False
For Each Column In InputWorksheet.Columns
ColumnNumber = ColumnNumber + 1
If Column.Cells(HeaderRow, 1) = "postalcode" Then
LastRow = Column.End(xlDown).Row
'I assume the Output column will be in the same position as the input column
Set OutputColumn = OutputWorksheet.Columns(ColumnNumber)
'If OutputColumn is always in Column 'D' then replace previous line with:
'Set OutputColumn = OutputWorksheet.Columns(4)
Set RangeInput = InputWorksheet.Range(Column.Cells(HeaderRow + 1, 1), Column.Cells(LastRow, 1))
Set RangeOutput = OutputWorksheet.Range(OutputColumn.Cells(HeaderRow + 1, 1), OutputColumn.Cells(LastRow, 1))
ColumnFound = True
Exit For
End If
Next
If ColumnFound Then
'Initialize Interior color to nothing
'and remove values from output column
RangeInput.Interior.ColorIndex = 0
RangeOutput.ClearContents
'Initialize Arrays (much faster than working with ranges)
InputValues = RangeInput.Value2
OutputValues = RangeOutput.Value2
'Change values and formatting
For i = 1 To RangeInput.Rows.Count
fullzipcode = InputValues(i, 1)
If Len(fullzipcode) > 5 Then
RangeInput.Cells(i, 1).Interior.Color = RGB(255, 0, 0)
InputValues(i, 1) = Left(fullzipcode, 5)
End If
OutputValues(i, 1) = fullzipcode
Next
'Save arrays to ranges
RangeInput.Value2 = InputValues
RangeOutput.Value2 = OutputValues
End If
End Sub
I need to compare two ranges and see if value in one range appears in the other. This is the code I use:
Dim rng1 As Range
Dim rng2 As Range
Dim cell as Range
Dim found as Range
set rng1 = ....
set rng2 = ....
for each cell in rng1
set found = rng2.Find(what:=cell,.....
Next cell
This code is OK if the range is in thousands of rows, single column. When it comes to tens of thousands, it's very slow.
Anyway to speed it up?
This might be the fastest way for large amounts of data:
Option Explicit
Sub Test()
Dim rng1 As Range
Set rng1 = YourShorterRange
Dim rng2 As Range
Set rng2 = YourLargerRange
Dim C As Range
Dim Matches As Object: Set Matches = CreateObject("Scripting.Dictionary")
'input the larger data inside a dictionary
For Each C In rng2
If Not Matches.Exists(C.Value) Then Matches.Add C.Value, 1
Next C
Dim i As Long
Dim arr As Variant
'input the shorter data inside an array
arr = rng1.Value
For i = 1 To UBound(arr)
If Matches.Exists(arr(i, 1)) Then
'your code if the value is found
End If
Next i
End Sub
Edit for Dorian:
Option Explicit
Sub Test()
Dim rng1 As Range
Set rng1 = YourShorterRange
Dim rng2 As Range
Set rng2 = YourLargerRange
Dim i As Long, j As Long
Dim arr As Variant
Dim Matches As Object: Set Matches = CreateObject("Scripting.Dictionary")
arr = rng1.Value
'input the larger data inside a dictionary
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Not Matches.Exists(arr(i, j)) Then Matches.Add arr(i, j), 1
Next j
Next i
'input the shorter data inside an array
arr = rng2.Value
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Matches.Exists(arr(i, j)) Then
'your code if the value is found
End If
Next j
Next i
End Sub
Maybe something along these lines:
Sub Test()
Dim arr1 As Variant, arr2 As Variant
Dim arrList As Object: Set arrList = CreateObject("System.Collections.ArrayList")
Dim x As Long
arr1 = rng1 'Specify your range
arr2 = rng2 'Specify your range
For x = LBound(arr2) To UBound(arr2)
arrList.Add arr2(x, 1)
Next x
For x = LBound(arr1) To UBound(arr1)
If arrList.contains(arr1(x, 1)) = True Then
Debug.Print arr1(x, 1) & " contained within range 2"
End If
Next x
End Sub
I would suggest you :
Application.match
You can also look here you will find an interesting studies on 3 different ways of Search. Those 3 Different way will be studied By Time and By number of occurences.
According Fastexcel the conclusion of this study is :
Don’t use Range.Find unless you want to search a large number of
columns for the same thing (you would have to do a Match for each
column).
The Variant array approach is surprisingly effective,
particularly when you expect a large number of hits.
Match wins easily
for a small number of hits.
So If you except a large number of hit you might have to give a try variant array method. The 3 ways are listed in Fastexcel tuto
Edit
After reading some comment I did a new test :
Variant code
Sub Test1()
Dim vArr As Variant
Dim j As Long
Dim n As Long
Dim dTime As Double
dTime = MicroTimer
vArr = Range("A1:B100000").Value2
Dim Matches As Object: Set Matches = CreateObject("Scripting.Dictionary")
arr = Range("G1:G15").Value
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Not Matches.Exists(arr(i, j)) Then Matches.Add arr(i, j), 1
Next j
Next i
For j = LBound(vArr) To UBound(vArr)
If Matches.Exists(vArr(j, 1)) Or Matches.Exists(vArr(j, 2)) Then n = n + 1
Next j
Debug.Print "Using Variant : " & n & " Timer :" & (MicroTimer - dTime) * 1000
End Sub
Dictionary
Sub Test()
Dim rng1 As Range
Set rng1 = Range("A1:B100000")
Dim rng2 As Range
Set rng2 = Range("G1:G15")
Dim i As Long, j As Long
Dim arr As Variant
Dim dTime As Double
dTime = MicroTimer
Dim Matches As Object: Set Matches = CreateObject("Scripting.Dictionary")
arr = rng2.Value
'input the larger data inside a dictionary
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Not Matches.Exists(arr(i, j)) Then Matches.Add arr(i, j), 1
Next j
Next i
'input the shorter data inside an array
arr = rng1.Value
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Matches.Exists(arr(i, j)) Then
'your code if the value is found
cpt = cpt + 1
End If
Next j
Next i
Debug.Print "Using Damian Method : " & cpt & " Timer : " & (MicroTimer - dTime) * 1000
End Sub
# This is the input table for which I want to perform some action #
Public Sub mac()
Dim RangeOfChild As Range
For i = 1 To 10000
ActiveCell.Range("A" & i).Activate
Dim DirArray As Variant
Dim temp As Variant
Set RangeOfChild = Range(ActiveCell.Offset(0, 1),ActiveCell.End(xlToRight))
childCount = RangeOfChild.count
temp = ActiveCell.Value
ActiveCell = Null
DirArray = RangeOfChild.Value
RangeOfChild.ClearContents
ActiveCell.EntireRow.Resize(childCount - 1).Insert Shift:=xlDown
ActiveCell.Value = temp
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(RangeOfChild.count - 1, 1)) = Application.Transpose(Array(DirArray))
i = i + (childCount)
Next i
End Sub
I want a output similar to the below image
enter image description here
But the written for loop is only doing the operation to two of the rows , not the remaining, If someone could help me out with this , it would be a great help.
I accomplished this task by using two worksheets: worksheets("SheetInput") which contains the input data and worksheets("SheetOutput") which receives the formatted output.
Option Explicit
Public Sub mac()
Dim wsData As Worksheet, wsOutput As Worksheet
Dim rngInput As Range, RangeOfChild As Range, rngOutput As Range
Dim childCount As Long
Set wsData = ThisWorkbook.Worksheets("SheetInput")
Set wsOutput = ThisWorkbook.Worksheets("SheetOutput")
Set rngInput = ThisWorkbook.Worksheets("SheetInput").Cells(1, 1)
Set rngOutput = ThisWorkbook.Worksheets("SheetOutput").Cells(1, 1)
While Not (IsEmpty(rngInput))
Set RangeOfChild = Range(rngInput.Offset(0, 1), rngInput.End(xlToRight))
childCount = RangeOfChild.Count
rngInput.Copy
rngOutput.PasteSpecial Paste:=xlPasteAll
RangeOfChild.Copy
rngOutput.Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Set rngInput = rngInput.Offset(1, 0)
Set rngOutput = rngOutput.Offset(childCount, 0)
Wend
End Sub
activate method is not good. use a variant array.
Sub test()
Dim rngDB As Range, rngCnt As Range
Dim rng As Range, rng2 As Range
Dim vCnt, vR()
Dim i As Integer, c As Integer, n As Long, s As Long
Set rngDB = Range("a1", Range("a" & Rows.Count).End(xlUp))
For Each rng In rngDB
Set rngCnt = Range(rng.Offset(, 1), rng.End(xlToRight))
s = n + 1
vCnt = rngCnt
c = rngCnt.Columns.Count
n = n + c
ReDim Preserve vR(1 To 2, 1 To n)
vR(1, s) = rng
For i = 1 To c
vR(2, s + i - 1) = vCnt(1, i)
Next i
Next rng
Sheets.Add
Range("a1").Resize(n, 2) = WorksheetFunction.Transpose(vR)
End Sub