Below is my code for the project I am doing, and for some reason I keep on getting an overflow error at the line:
totalAmountWeight = (ActiveWorkbook.Worksheets("Product Info").Cells(p, 8).Value) / (ActiveWorkbook.Worksheets("Product Info").Cells(p, 7).Value)
I am not sure why this error is occurring or how to fix it.
Private Sub Worksheet_Calculate()
Dim target As Range
Set target = Range("Q1")
Dim p As Long
Dim o As Long
Dim r As Long
Dim Length As Single
Dim Width As Single
Dim Height As Single
Dim totalAmountWeight As Double
Dim i As Integer, intValueToFind As Integer
Dim sheet As Worksheet
Set sheet = ThisWorkbook.Worksheets("Product Info")
'lastrow = sheet.Cells(sheet.Rows.Count, "B").End(xlUp).row
lastrow = Range("B" & Rows.Count).End(xlUp).Row
o = 1
r = 1
If Not Intersect(target, Range("Q1")) Is Nothing Then
For p = 2 To lastrow
Length = ActiveWorkbook.Worksheets("Product Info").Cells(p, 2).Value
Width = ActiveWorkbook.Worksheets("Product Info").Cells(p, 3).Value
Height = ActiveWorkbook.Worksheets("Product Info").Cells(p, 4).Value
totalAmountWeight = (ActiveWorkbook.Worksheets("Product Info").Cells(p, 8).Value) / (ActiveWorkbook.Worksheets("Product Info").Cells(p, 7).Value)
ActiveWorkbook.Worksheets("Backend").Range("O1").Value = totalAmountWeight
Call boxes(Length, Width, Height)
Call boxesLast3(Length, Width, Height)
intValueToFind = 0
For i = 2 To 7 ' Revise the 500 to include all of your values
If ActiveWorkbook.Worksheets("Backend").Cells(i, 5).Value = intValueToFind Then
'MsgBox ("Found value on row " & i)
ActiveWorkbook.Worksheets("Backend").Cells(i, 7).Value = 600
ActiveWorkbook.Worksheets("Backend").Cells(i, 8).Value = 400
ActiveWorkbook.Worksheets("Backend").Cells(i, 9).Value = 325
Else
'MsgBox ("Value not found in the range!")
'MsgBox ActiveWorkbook.Worksheets("Backend").Cells(i, 5).Value
End If
Next i
Call LWextra(Height, Length, Width)
Call HWextra(Height, Length, Width)
Call LHextra(Height, Length, Width)
Call HLextra(Height, Length, Width)
Call WLextra(Height, Length, Width)
Call WHextra(Height, Length, Width)
newamount = ActiveWorkbook.Worksheets("Backend").Range("Q1").Value
dimensions = ActiveWorkbook.Worksheets("Backend").Range("K13").Value
ActiveWorkbook.Worksheets("Backend").Cells(o, 26).Value = newamount
o = o + 1
ActiveWorkbook.Worksheets("Backend").Cells(r, 27).Value = dimensions
r = r + 1
Next p
End If
End Sub
Related
I want to populate my shape according to time range value in 1st Range and 2nd Range cell as shown in the image. Thank you. Your help is much appreciated
https://i.stack.imgur.com/XNNy2.jpg
I've tried this code but it won't work.
Dim z As Range
For Each z In Range("a4:a19").Rows
If z.Value >= Range("F4") Then Exit For
Next z
Dim x As Range
For Each x In Range("a4:a19").Rows
If x.Value >= Range("G4") Then Exit For
Next x
'MsgBox z & x
Dim c
Dim rnrn
c = Rows(3).Find(DateValue("12/11/2022")).Column
'Application.InchesToPoints(10)
Dim LLL As Single, TTT As Single, WWW As Single, HHH As Single
Set rnrn = Range(z.Address, x.Address).Offset(0, c - 1)
LLL = rnrn.Left
TTT = rnrn.Top
WWW = rnrn.Width
HHH = rnrn.Height
With ActiveSheet.Shapes
' .LockAspectRatio = msoFalse
.AddTextbox(msoTextOrientationHorizontal, LLL, TTT + Application.InchesToPoints(Range("F4").Value), WWW, Application.InchesToPoints(Range("F4").Value) + Application.InchesToPoints(Range("G4").Value)).Select
' .Placement = xlMove
' .LockAspectRatio = msoTrue
End With
Dim r1 As Byte, r2 As Byte, r3 As Byte
r1 = WorksheetFunction.RandBetween(0, 255)
r2 = WorksheetFunction.RandBetween(0, 255)
r3 = WorksheetFunction.RandBetween(0, 255)
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(r1, r2, r3)
.Transparency = 0
.Solid
End With
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
With Selection.ShapeRange.TextFrame2.TextRange.Characters.ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
Selection.ShapeRange.TextFrame2.TextRange.Characters.Font.Size = 15
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = Range("F3").Text & " - " & Range("G3").Text
If I understand you correctly....
Below image is an example before running the sub
The expected result after running the sub :
If the image both is similar with your case, then maybe you want to have a look the code below then modify it according to your need. The code don't do any "fancy stuffs", such as coloring, font type, font size, etc.
Sub test()
Dim rg As Range: Dim sTxt As String: Dim eTxt As String
Dim dur: Dim pos
Dim h As Integer: Dim w As Integer
Dim L As Integer: Dim T As Integer
With ActiveSheet
For Each shp In .Shapes: shp.Delete: Next
End With
Set rg = Range("F2", Range("F" & Rows.Count).End(xlUp))
For Each cell In rg
sTxt = Format(cell.Value, "hh:mm AM/PM")
eTxt = Format(cell.Offset(0, 1).Value, "hh:mm AM/PM")
dur = Format(cell.Offset(0, 1).Value - cell.Value, "h:m")
dur = Split(dur, ":")(0) & "." & Application.RoundUp(Split(dur, ":")(1) * 1.666, 0)
pos = Format(cell.Value, "h:m")
pos = Split(pos, ":")(0) & "." & Application.RoundUp(Split(pos, ":")(1) * 1.666, 0)
With Range("D4")
h = dur * .Height: w = .Width
L = .Left: T = .Top + ((pos - 7) * .Height)
End With
With ActiveSheet.Shapes
.AddTextbox(msoTextOrientationHorizontal, L, T, w, h) _
.TextFrame.Characters.Text = sTxt & " - " & eTxt
End With
Next
End Sub
For the textbox size,
the height is coming from subtracting the end time with start time, split the value by ":", then add decimal point ".", then multiply the value after the decimal point with 1.666, so the approx value can be divided by 100, not 60, then multiply by the row height of row 4. The width is coming from column D width.
For the textbox position,
The top position is coming from the start time, then it
s the same process like for the height of the box. The left position is coming from the left position value of column D.
Option Explicit
Sub trial()
Dim rng As Range
Dim celladdress As String
Dim myrange As Variant
Dim word As Variant
Set rng = Range("G3:G1000").Find(what:="Description")
rng.Find what:="Description"
celladdress = rng.Address
Dim max As Range
Dim b As Integer
b = Worksheets("Sheet1").Cells(Rows.count, "a").End(xlUp).Row
Set max = Range("G2", celladdress)
For Each word In max
If word = "Moisture Content" Then
Cells(b + 1, 24) = word.Offset(0, 1)
Exit For
End If
Next word
For Each word In max
If word = "Grading Class" Then
Cells(b + 1, 16) = word.Offset(0, 1)
Exit For
End If
Next word
For Each word In max
If word = "Zone X Constituent Parts" Then
Cells(b + 1, 17) = word.Offset(0, 1)
Exit For
End If
Next word
For Each word In max
If word = "Plastic Limit" Then
Cells(b + 1, 18) = word.Offset(0, 1)
Exit For
End If
Next word
For Each word In max
If word = "Liquid Limit" Then
Cells(b + 1, 19) = word.Offset(0, 1)
Exit For
End If
Next word
For Each word In max
If word = "Plasticity Index" Then
Cells(b + 1, 20) = word.Offset(0, 1)
Exit For
End If
Next word
Each word In max
If word = "Particle Density" Then
Cells(b + 1, 21) = word.Offset(0, 1)
Exit For
End If
Next word
For Each word In max
If word = "Optimum Moisture Content" Then
Cells(b + 1, 22) = word.Offset(0, 1)
Exit For
End If
Next word
For Each word In max
If word = "Maximum Dry Density" Then
Cells(b + 1, 23) = word.Offset(0, 1)
Exit For
End If
Next word
For Each word In max
If word = "Shear Strength at OMC" Then
Cells(b + 1, 15) = word.Offset(0, 1)
Exit For
End If
Next
Dim txt As String
Dim i As Integer
Dim reference As Variant
Dim k As Integer
Dim c As Integer
c = Worksheets("Sheet1").Cells(Rows.count, "a").End(xlUp).Row
txt = Cells(2, 5).Value
reference = Split(txt, " ")
For i = 0 To UBound(reference)
Cells(c + 1, 4).Value = reference(i)
next
txt = Cells(2, 5).Value
reference = Split(txt, " ")
For k = 0 To LBound(reference)
Cells(c + 1, 9).Value = reference(k)
Next k
Dim Last_Row As Long
Last_Row = Range("C3").End(xlDown).Offset(1).Row
Cells(Last_Row, [13]).Value = "Sampling"
Range("C3").Copy Range("C" & Last_Row)
Range("B3").Copy Range("B" & Last_Row)
Range("A3").Copy Range("A" & Last_Row)
Dim rnge As Range
Dim celladdres As String
Set rnge = Range("G3:G1000").Find(what:="Description")
rng.Find what:="Description"
celladdres = rnge.Address.Offset(-1, 50) - Invalid error
Dim maxy As Range
Set maxy = Range("G2", celladdress)
Worksheets("Sheet1").Range(max).Delete
End Sub
Hi i keep getting an invalid qualifer error and im unsure why. Im trying to get the find the next description and then offset the cell so i can delete all the information in the row above and 50 column along. im unsure why the error keep ocurring and what it actually means. any help would be greatly appreicated thanks max
in the code:
Sub sync()
Dim Dindex As Long 'the index of the D value we are on currently.
Dim Aindex As Long 'the index of the A value we are on currently
Dim Gindex As Long 'the index of the A value we are on currently
Dim Dvalue As Double 'the cell in D value we want to normalize by -time
Dim Avalue As Double 'the A cell value - time
Dim Bvalue As Double
Dim Hvalue As Double
Dim Gvalue As Double 'the G cell value - time
Dindex = 3
Aindex = 3
Gindex = 3
Dvalue = Cells(Dindex, 4).Value 'start value
Avalue = Cells(Aindex, 1).Value 'start value
Gvalue = Cells(Gindex, 7).Value
Do While Dvalue <> 0
Do While Avalue < Dvalue
Aindex = Aindex + 1
Avalue = Range("A" & CStr(Aindex)).Value
Loop
Do While Gvalue < Dvalue
Gindex = Gindex + 1
Gvalue = Range("G" & CStr(Gindex)).Value
Loop
Bvalue = Cells(Aindex, 2)
If Avalue <> Dvalue Then
Aindex = Aindex - 1
Bvalue = (Bvalue + Range("A" & CStr(Aindex)).Value) / 2
End If
Hvalue = Cells(Gindex, 8).Value
If Gvalue <> Dvalue Then
Gindex = Gindex - 1
Hvalue = (Hvalue + Range("G" & CStr(Gindex)).Value) / 2
End If
Cells(Dindex, 10).Value = Dvalue
Cells(Dindex, 11).Value = Bvalue
Cells(Dindex, 12).Value = Hvalue
Dindex = Dindex + 1
Dvalue = Cells(Dindex, 4).Value
Loop
End Sub
I got the error when in the line: Avalue = Range("A" & CStr(Aindex)).Value when the value Aindex got to 1048577. I suspect that the problem is in me trying to reach to such a large cell, the goal of the code is to put 3 different time systems values on the same time system, so I need to reach beyond that cell.
thanks to BigBen I found out that that the maximum value of an excel column is 1048576, and successfully fixed my code.
I am new to VBA. i have created triangles which i need to place into the 1st empty row above the given data.
Eg: Please Refer the image.
1) Output after running below code. Yellow marked lines is the row where the output should be shown.
2) actual output it should look like this . (I have edited it manually )
I have created triangle for every data in column c. which i have matched to RANGE(I4:AK4),
but as you can see in image, i am getting output in row 13 in actual it should be in empty row.
It is just my idea: As empty row should be used as the output for the given below data.
For Eg: ROW 20 should be used as output row for given below data in column C (C21,C22,C23)
Please refer the code below as i have tried to create triangle but not able to move to 1st empty row to given below data.
Sub addshape()
Dim lastrow As Long
Dim lastCol As Long
Dim heightCell As Long
Dim widthCell As Long
Dim R As Excel.Range
Dim i As Long
Dim l As Long
Dim s As Shape
With ThisWorkbook.Sheets("Tabelle1")
lastrow = .Cells(Rows.Count, 2).End(xlUp).Row
lastCol = .Cells(4, Columns.Count).End(xlToLeft).Column
For i = 6 To lastrow
If .Cells(i, 3) = " " Then
Else
Set R = .Range(.Cells(4, 9), .Cells(4, lastCol))
If IsEmpty(.Cells(i, 3).Value) = False Then
Set s = ActiveSheet.Shapes.addshape(msoShapeIsoscelesTriangle, 51, 220, 14, 12)
With s
.Name = "triangle" & i
.Rotation = 180
.TextFrame.Characters.Text = Cells(i, 2)
.TextFrame.Characters.Font.Size = 10
.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Line.Weight = 1
.Line.ForeColor.RGB = RGB(0, 0, 0)
.TextEffect.Alignment = msoTextEffectAlignmentCentered
.TextFrame.Orientation = msoTextOrientationHorizontal
.TextFrame.VerticalOverflow = xlOartVerticalOverflowOverflow
.Fill.ForeColor.RGB = RGB(245, 144, 66)
End With
s.Left = 10
l = Application.WorksheetFunction.Match(.Cells(i, 3), R, 0)
l = R(1, l).Left
l = l + (R(1, l).Width / 24)
s.Left = l
End If
End If
Next i
End With
End Sub
Please share your ideas or your codes.
Will be thankful.
What you can do is loop over all your cells backwards to find the first blank cell above the cell you're working from. Then Align the top to the found cell. Concept:
j = i 'Using a new variable to start from i so to not mess up variable i.
Set A = .Range("B1") 'set a range as a blank range will throw an error when used.
Do Until A = "" 'loop until A is assigned a blank cell
j = j - 1 'step -1 to loop backwards
Set A = .Cells(j, 3) 'assign cell to A as one above the last one.
Loop
s.Top = A.Top 'align top of shape to top of found cell.
In your code this would look like so:
Sub addshape()
Dim lastrow As Long
Dim lastCol As Long
Dim heightCell As Long
Dim widthCell As Long
Dim R As Excel.Range
Dim i As Long
Dim j As Long
Dim l As Long
Dim s As Shape
Dim A As Range
With ThisWorkbook.Sheets("Tabelle1")
lastrow = .Cells(Rows.Count, 2).End(xlUp).Row
lastCol = .Cells(4, Columns.Count).End(xlToLeft).Column
For i = 6 To lastrow
If .Cells(i, 3) = " " Then
Else
Set R = .Range(.Cells(4, 9), .Cells(4, lastCol))
If IsEmpty(.Cells(i, 3).Value) = False Then
Set s = ActiveSheet.Shapes.addshape(msoShapeIsoscelesTriangle, 51, 220, 14, 12)
With s
.Name = "triangle" & i
.Rotation = 180
.TextFrame.Characters.Text = Cells(i, 2)
.TextFrame.Characters.Font.Size = 10
.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
.Line.Weight = 1
.Line.ForeColor.RGB = RGB(0, 0, 0)
.TextEffect.Alignment = msoTextEffectAlignmentCentered
.TextFrame.Orientation = msoTextOrientationHorizontal
.TextFrame.VerticalOverflow = xlOartVerticalOverflowOverflow
.Fill.ForeColor.RGB = RGB(245, 144, 66)
End With
s.Left = 10
l = Application.WorksheetFunction.Match(.Cells(i, 3), R, 0)
l = R(1, l).Left
l = l + (R(1, l).Width / 24)
s.Left = l
j = i
Set A = .Range("B1")
Do Until A = ""
j = j - 1
Set A = .Cells(j, 3)
Loop
s.Top = A.Top
End If
End If
Next i
End With
End Sub
I have the follow script to put a list of people with there know skills in an array and then match the first match with a customer with the same skill. Every time it runs the results are the same. I would like to have it be a random order of the array, but keeping the two columns in the array together. How can I shuffle(rearrange) the array that keeps the rows in the array the same? Or would it be better to erase the array, randomly sort the columns and set the array back up?
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
p = 0
o = 0
For i = 2 To 920
If Cells(i, 12).Value <> Cells(i - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(i, 12).Value
arOne(p, 1) = Cells(i, 13).Value
o = 2
Else
arOne(p, o) = Cells(i, 13).Value
o = o + 1
End If
Next
For i = 2 To 612
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & i), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(i, 2).Value Then
Cells(i, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
GoTo NextIR
End If
Next j
End If
End If
Next o
NextIR:
Next i
End Sub
Multiple loops and multiple access to range objects makes your code very, very slow (I don't know if performance is important).
I would read all necessary data to arrays and use filter and rnd to get a random person with the relevant skill:
Option Explicit
Sub PeopleBusiness()
Dim People, Customers, FilterArray
Dim I As Long, Idx As Long
People = Application.Transpose([L2:L920 & "|" & M2:M8])
Customers = Range("A2:C612").Value2
For I = 1 To UBound(Customers, 1)
FilterArray = Filter(People, Customers(I, 2))
If UBound(FilterArray) > -1 Then
Idx = Round(Rnd() * UBound(FilterArray), 0)
Customers(I, 3) = Left(FilterArray(Idx), InStr(1, FilterArray(Idx), "|") - 1)
End If
Next I
Range("A2:C612").Value = Customers
End Sub
I was able to get done what I needed by erasing the array and redimming it after sorting the data based on a rand() number in the table. It takes about 15 minutes to run 7000 assignment but it is a lot better than 7+ hours it takes to do manually.
Sub Assign()
Dim arOne()
ReDim arOne(1000, 15)
Dim o As Integer
Dim p As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
Application.Calculation = xlAutomatic
StartTime = Timer
NextIR:
ReDim arOne(1000, 15)
p = 0
o = 0
QAlr = Sheets("Sheet1").Range("L" & Rows.Count).End(xlUp).Row
For I = 2 To QAlr
If Cells(I, 12).Value <> Cells(I - 1, 12) Then
p = p + 1
arOne(p, 0) = Cells(I, 12).Value
arOne(p, 1) = Cells(I, 13).Value
o = 2
Else
arOne(p, o) = Cells(I, 13).Value
o = o + 1
End If
Next
AQAlr = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
AgtLr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For I = AQAlr + 1 To AgtLr
For o = LBound(arOne, 1) + 1 To UBound(arOne, 1)
If arOne(o, 0) <> "" Then
iUsed = Application.WorksheetFunction.CountIf(Range("C2:C" & I), "=" & arOne(o, 0))
If iUsed < Application.WorksheetFunction.VLookup(arOne(o, 0), Range("Q2:R62"), 2, False) Then
For j = LBound(arOne, 2) + 1 To UBound(arOne, 2)
If arOne(o, j) = Cells(I, 2).Value Then
Cells(I, 3).Value = arOne(o, 0)
ActiveSheet.Calculate
Erase arOne()
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Random '#]]"), SortOn:=xlSortOnValues, Order:= _
xlDescending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
GoTo NextIR
End If
Next j
End If
End If
Next o
Next I
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Assignments completed in " & MinutesElapsed & " minutes", vbInformation
End Sub
Not entirely sure I got your set-up right but you can try this:
Option Explicit
Sub Assign()
Randomize
Range("C2", Range("C" & Rows.Count).End(xlUp)).ClearContents
Dim R1 As Range: Set R1 = Range("L2:M920") 'People skill table
Dim R2 As Range: Set R2 = Range("A2:B612") 'Cusotmers skill talbe
Dim D0 As Object: Set D0 = CreateObject("scripting.dictionary")
Dim i As Integer, j As Integer, Rand as Integer
For i = 1 To R2.Rows.Count
Rand = Int(R1.Rows.Count * Rnd + 1)
For j = 1 To R1.Rows.Count
If R1.Cells(Rand, 2) = R2(i, 2) And Not D0.exists(Rand) Then
R2.Cells(i, 2).Offset(0, 1) = R1(Rand, 1)
D0.Add Rand, Rand
Exit For
End If
Rand = (Rand Mod R1.Rows.Count) + 1
Next j
Next i
End Sub
The idea is to check the people skill list starting from a random point and making sure a key is not used twice.
EDIT:
According to your comment I assume a "people / skill" can then be assigned more than once as there are 7000+ customers ?
Code below randomly assign with a fairly good distribution 1500 peoples to 7000 customers in +/- 1 second.
Have a try and see if you can adapt it to your project.
Option Explicit
Sub Assign()
Application.ScreenUpdating = False
Dim Start: Start = Timer
Randomize
Range("C2:C99999").ClearContents
Dim D1 As Object
Dim R1 As Range: Set R1 = Range("L2", Range("M" & Rows.Count).End(xlUp))
Dim R2 As Range: Set R2 = Range("A2", Range("B" & Rows.Count).End(xlUp))
Dim T1: T1 = R1
Dim T2: T2 = R2
Dim T3()
Dim a As Integer: a = 1
Dim i As Integer, j As Integer, k As Integer, Rnd_Val As Integer, j_loop As Integer
For i = 1 To (Int(R2.Rows.Count / R1.Rows.Count) + 1)
Set D1 = CreateObject("scripting.dictionary")
For j = (R1.Rows.Count * i - R1.Rows.Count + 1) To R1.Rows.Count * i
ReDim Preserve T3(1 To j)
Rnd_Val = Int(Rnd * R1.Rows.Count + 1)
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) And Not D1.exists(Rnd_Val) And T3(j) = "" Then
T3(j) = T1(Rnd_Val, 1)
D1.Add Rnd_Val, Rnd_Val
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
If T3(j) = "" Then
For k = 1 To R1.Rows.Count
If T1(Rnd_Val, 2) = T2(j, 2) Then
T3(j) = T1(Rnd_Val, 1)
Exit For
End If
Rnd_Val = (Rnd_Val Mod R1.Rows.Count) + 1
Next k
End If
a = a + 1
If a > R2.Rows.Count Then GoTo EndLoop
Next j
Set D1 = Nothing
Next i
EndLoop:
Range("C2").Resize(UBound(T3), 1) = Application.Transpose(T3)
Debug.Print Timer - Start
Application.ScreenUpdating = True
End Sub