if i have a column in excel in following format:
"dd/mm/yyyy hh:mm:ss" and i want to increase the hour value by 1.
I add 1/24 to that cell and is done.
my problem is that files where i need this correction have around 15000 rows and operation is taking around 2 minutes.
the code i use is:
Set rngSel = .Range("A2:A10000")
For Each cell In rngSel
cell.Value = cell.Value + dif / 24
Next cell
is it possible somehow to do it faster?
You could try:
Option Explicit
Sub test()
Dim arr As Variant
Dim Initial_DateTime As Date
Dim i As Long
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range("A2:A10000")
For i = LBound(arr) To UBound(arr)
Initial_DateTime = arr(i, 1)
arr(i, 1) = DateAdd("h", 1, Initial_DateTime)
Next i
.Range("A2:A1000").Value = arr
End With
End Sub
As mentioned in the comments, it is much quicker to load the range into a matrix and handle the incrementation of the dates in memory. I have built upon your code for the following example.
Sub IncrementDateColumnByVBA()
Dim rngSel As Range
Dim DateArray() As Variant
Dim i As Long
Dim dif As Byte
dif = 1
Set rngSel = ActiveSheet.Range("A2:A10")
'Write range to a matrix
DateArray = rngSel.Value
'Loop matrix
For i = LBound(DateArray) To UBound(DateArray)
DateArray(i, 1) = DateArray(i, 1) + dif / 24
Next i
'Write matrix to worksheet
rngSel.Value = DateArray
End Sub
Related
I'd like to multiply the cells of column P with the cells in column M and replace the content of column P with the respective product. Afterwards I want to do the exact same thing with columns Q and N.
I've been trying to look this issue up and the closest solution was: VBA multiply two named ranges
Unfortunately, after running through the first column and calculating it, Excel gives me a runtime error 13 - type mismatch.
My code:
Sub rechnen_mod()
Dim aud_y As Range
Dim soc_r As Range
Dim mp_y As Range
Dim mp_r As Range
Set aud_y = Sheets("MRP score template").[P11:P1000]
Set soc_r = Sheets("MRP score template").[Q11:Q1000]
Set mp_y = Sheets("MRP score template").[M11:M1000]
Set mp_r = Sheets("MRP score template").[N11:N1000]
For i = 1 To Range("P").End(xlDown).Row
aud_y(i, 1) = aud_y(i, 1) * mp_y(i, 1)
Next i
For j = 1 To Range("Q").End(xlDown).Row
soc_r(j, 1) = soc_r(j, 1) * mp_r(j, 1)
Next j
End Sub
Any help would be very appreciated.
EDIT: After reading <stackoverflow.com/a/22056347/11231520> I changed the code to:
Public Sub array1()
Dim x As Long
Dim arr
Dim arr_e
Dim arrf
Dim arrf_e
Dim results
Dim r As Range
arr = Sheets("MRP score template").[P11:P473]
arrf = Sheets("MRP score template").[M11:M473]
ReDim results(1 To UBound(arr) * UBound(arrf))
For Each arr_e In arr
For Each arrf_e In arrf
x = x + 1
results(x) = arr_e * arrf_e
Next arrf_e
Next arr_e
Set r = Sheets("calc").Range("A1:A" & UBound(results))
r = Application.Transpose(results)
End Sub
Excel gives me a runtime error 13 - type mismatch with the explanation that arrf_e = error 2402. After a quick research this should mean that the array contains #NA - but it doesn't.
After clicking on debugging, the marked line is
results(x) = arr_e * arrf_e
Try to use below code instead. I also added comments to explain each step :)
Option Explicit
Public Sub rechnen_mod()
Dim mp_y() As Variant
Dim mp_r() As Variant
Dim aud_y() As Variant
Dim soc_r() As Variant
Dim arrResult_P() As Variant
Dim arrResult_Q() As Variant
Dim iLastRow As Integer
Dim iSizeArrays As Integer
Dim iIndexSearch As Integer
With ThisWorkbook.Worksheets("MRP score template")
' Find last row of table, replace it with fixed value if you prefer
iLastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
' Store data in arrays
mp_y = .Range("M11", "M" & iLastRow).Value
mp_r = .Range("N11", "N" & iLastRow).Value
aud_y = .Range("P11", "P" & iLastRow).Value
soc_r = .Range("Q11", "Q" & iLastRow).Value
' Calculate size of arrays
iSizeArrays = UBound(mp_y) - LBound(mp_y) + 1
' ReDim result arrays according to iSizeArrays
ReDim arrResult_P(1 To iSizeArrays)
ReDim arrResult_Q(1 To iSizeArrays)
' Calculate result values
For iIndexSearch = 1 To iSizeArrays
arrResult_P(iIndexSearch) = mp_y(iIndexSearch, 1) * aud_y(iIndexSearch, 1)
arrResult_Q(iIndexSearch) = mp_r(iIndexSearch, 1) * soc_r(iIndexSearch, 1)
Next iIndexSearch
' Write results in the worksheet
.Range("P11", "P" & iLastRow) = Application.WorksheetFunction.Transpose(arrResult_P)
.Range("Q11", "Q" & iLastRow) = Application.WorksheetFunction.Transpose(arrResult_Q)
End With
End Sub
I tested it with random values on 250 rows and it worked fine.
I have two set of range named as LIST_KEY and LIST_CAT. In Column A, user will add some data which will contain one of the one of the text from LIST_KEY. I would like to get corresponding Category list from LIST_CAT depends upon the Key value
I am using below VBA code to achieve this. This include a Array formula.
Sub match()
Dim ss As Workbook
Dim test As Worksheet
Set ss = Excel.Workbooks("test.xlsm")
Set test = ss.Worksheets("Sheet1")
For i = 2 To test.Cells(Rows.Count, "A").End(xlUp).Row
Cells(i, "B").FormulaArray = "=INDEX(LIST_CAT,MATCH(TRUE,ISNUMBER(SEARCH(LIST_KEY,RC[-1])),0))"
Cells(i, "B").Formula = Cells(i, "B").Value
Next i
End Sub
This code works perfect if there is less data to fetch. But in my original use case, I will have around 8000 rows. Due to this large number of columns excel will go to not responding state after 2-3 minutes.
Instead of adding Array formula to column B, Is there anyway to convert that into VBA to run this faster. Sorry, I am new to this VBA stuff and dont have much experience
Try the following code, which uses arrays instead of worksheet formulas...
Option Explicit
Sub GetCategories()
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Workbooks("test.xlsm")
Dim sourceWorksheet As Worksheet
Set sourceWorksheet = sourceWorkbook.Worksheets("Sheet1")
Dim lookupArray As Variant
lookupArray = sourceWorkbook.Names("LIST_KEY").RefersToRange.Value
Dim returnArray As Variant
returnArray = sourceWorkbook.Names("LIST_CAT").RefersToRange.Value
Dim tableArray As Variant
Dim lastRow As Long
With sourceWorksheet
lastRow = .Cells(.Rows.Count, "a").End(xlUp).Row
tableArray = .Range("A2:B" & lastRow).Value
End With
Dim desc As String
Dim i As Long
Dim j As Long
For i = LBound(tableArray, 1) To UBound(tableArray, 1)
desc = tableArray(i, 1)
For j = LBound(lookupArray, 1) To UBound(lookupArray, 1)
If InStr(1, desc, lookupArray(j, 1), vbTextCompare) > 0 Then
tableArray(i, 2) = returnArray(j, 1)
Exit For
End If
Next j
Next i
sourceWorksheet.Range("B2").Resize(UBound(tableArray, 1), 1).Value = Application.Index(tableArray, 0, 2)
End Sub
I wanted to copy data that fulfil a few criteria from one sheet to another using VBA.
My goal:
Copy Cell in column E, F and G in Sheet FP to column R, S and T in Sheet MUOR if it meets my conditions.
My conditions:
(1) Cell in Column D & Cell in Column P (in Sheet MUOR) must meet the condition in Column I of Sheet FP.
(2) If Cell in Column D is empty, skip to next Cell in Column D.
(3) Column R, S or T must be empty before pasting it. If not empty, move to the next cell that meets the condition. (Do not replace or duplicate the data)
Other information: Max Batch No (Column D) per day is 3;
Issue Facing:
My current VBA code doesn't recognise my conditions. It totally ignored my Day 1 data, and it duplicated all the Day 2 data.
Please refer to the attached images.
Sheet MUOR
Sheet FP
My expected Result
Sample Data here
My current code as below:
Sub LinkData()
Dim y As Long
Dim x As Long
Dim z As Long
Dim lr As Long
Dim arr As Variant
Dim FP As Worksheet
Dim MUOR As Worksheet
Set FP = ThisWorkbook.Sheets("FP")
Set MUOR = ThisWorkbook.Sheets("MUOR")
With FP
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
arr = .Range("A1:I" & lr).Value
End With
With MUOR
For y = 11 To 363
For z = y - 1 To y + 8
For x = LBound(arr) To UBound(arr)
If Cells(11 + y, 4) <> "" And Cells(11 + y, 4) & Cells(10 + z, 16) = arr(x, 9) And IsEmpty(Cells(10 + z, 18)) Then
.Cells(10 + z, 18) = arr(x, 5)
.Cells(10 + z, 19) = arr(x, 8)
.Cells(10 + z, 20) = arr(x, 7)
Else
End If
Next x
Next z
Next y
End With
End Sub
Any VBA expert please help me.
Much appreciated!
I think code below should give expected output, but not totally sure, since the workbook uploaded/shared seems to differ from the screenshots in the question.
Option Explicit
Private Sub LinkData()
Dim arrayFromFPSheet() As Variant
arrayFromFPSheet = GetSourceArray()
Dim MUOR As Worksheet
Set MUOR = ThisWorkbook.Worksheets("MUOR")
Dim rangesToLoopThrough As Range
Set rangesToLoopThrough = GetDestinationAreas(MUOR)
With MUOR
Dim area As Range
For Each area In rangesToLoopThrough.Areas
Debug.Assert area.Rows.CountLarge > 1 And area.Rows.CountLarge < 20
Dim areaFirstRowIndex As Long
areaFirstRowIndex = area.Rows(1).Row
Dim areaLastRowIndex As Long
areaLastRowIndex = area.Rows(area.Rows.Count).Row
Dim readRowIndex As Long
For readRowIndex = areaFirstRowIndex To areaLastRowIndex
If Not IsCellEmpty(.Cells(readRowIndex, "D")) Then
Dim batchNumber As String
batchNumber = CStr(.Cells(readRowIndex, "D"))
Dim writeRowIndex As Long
For writeRowIndex = areaFirstRowIndex To areaLastRowIndex
If IsCellEmpty(.Cells(writeRowIndex, "R")) And IsCellEmpty(.Cells(writeRowIndex, "S")) And IsCellEmpty(.Cells(writeRowIndex, "T")) Then
Dim Grade As String
Grade = CStr(.Cells(writeRowIndex, "P"))
Dim batchNumberAndGrade As String
batchNumberAndGrade = batchNumber & Grade
Dim n As Variant
n = Application.CountIfs(.Range("P" & areaFirstRowIndex, "P" & writeRowIndex), Grade, .Range("R" & areaFirstRowIndex, "R" & writeRowIndex), batchNumber) + 1
Debug.Assert IsNumeric(n)
Dim sourceRowIndex As Long
sourceRowIndex = GetRowIndexOfNthMatch(n, arrayFromFPSheet, batchNumberAndGrade, 9)
If sourceRowIndex > 0 Then
.Cells(writeRowIndex, "R") = arrayFromFPSheet(sourceRowIndex, 5)
.Cells(writeRowIndex, "S") = arrayFromFPSheet(sourceRowIndex, 8)
.Cells(writeRowIndex, "T") = arrayFromFPSheet(sourceRowIndex, 7)
End If
End If
Next writeRowIndex
End If
Next readRowIndex
Next area
End With
End Sub
Private Function GetDestinationAreas(ByVal someSheet As Worksheet) As Range
' Crudely clusters/groups destination sheet into areas (which
' should be date-specific, although this function will not check/verify
' output).
Const START_ROW_INDEX As Long = 10
Dim outputRange As Range
Set outputRange = someSheet.Range("C" & START_ROW_INDEX, "C" & someSheet.Rows.Count)
On Error Resume Next
Set outputRange = outputRange.SpecialCells(xlCellTypeConstants) ' Will raise error if no constants found.
On Error GoTo 0
Debug.Assert Not (outputRange Is Nothing)
Set GetDestinationAreas = outputRange
End Function
Private Function GetSourceArray() As Variant
With ThisWorkbook.Worksheets("FP")
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim outputArray() As Variant
outputArray = .Range("A1:I" & lastRow).Value
End With
GetSourceArray = outputArray
End Function
Private Function IsCellEmpty(ByVal someCell As Range) As Boolean
' https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/isempty-function
' "IsEmpty only returns meaningful information for variants."
' So using below function instead.
IsCellEmpty = Len(CStr(someCell.Value)) = 0
End Function
Private Function GetRowIndexOfNthMatch(ByVal n As Long, ByRef someArray() As Variant, ByVal someText As String, ByVal targetColumn As Long) As Long
' Returns a 1-based row index of the nth occurrence of text value
' in target column of array or 0 if unsuccessful.
Debug.Assert n > 0
Dim rowIndex As Long
For rowIndex = LBound(someArray, 1) To UBound(someArray, 1)
If someArray(rowIndex, targetColumn) = someText Then
Dim matchCount As Long
matchCount = matchCount + 1
If matchCount = n Then
GetRowIndexOfNthMatch = rowIndex
Exit Function
End If
End If
Next rowIndex
End Function
Thanks for all the information you provided in the question. It makes it easier to answer.
First I'm open to do this with an other angle.
I want to count the total hours of work hours estimated, see sheet2. In another sub I've calculated the total work hours (timer tot) with worksheetfunction.sum and timer FRJ/HET with worksheetfunction.sumif. This code doesn't consider overlapping days which means if the dates intersect each other it will calculate 8*2(3,4,5...) (8 hours is average workday in Norway) instead of 8 hours per workday. This will mess up the total amount of time estimated and posibly we will estimate more hours per day than 24 hours :D
I've started this code underneath which I will use to substract the total amount of time and total amout for FRJ and HET.
Code:
Sub Overlapping_WorkDays()
Dim rng_FRJ_HET As Range
Dim cell_name As Range
Dim startDateRng As Range
Dim endDateRng As Range
Set rng_FRJ_HET = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown))
Set startDateRng = Sheet1.Range("D8", Sheet1.Range("D8").End(xlDown))
Set endDateRng = Sheet1.Range("E8", Sheet1.Range("E8").End(xlDown))
For Each cell_name In rng_FRJ_HET
If cell_name = "FRJ" Then
'Count Overlapping networkdays for FRJ
Elseif cell_name = "HET" Then
'Count Overlapping networkdays for HET
End If
Next cell_name
End Sub
Sheet1 screenshot
Sheet2 screenshot
All you need to do is loop through all the date ranges and count them if they haven't already been counted. A Dictionary from the Microsoft Scripting Runtime is well suited for this (you'll need to add a reference in Tools->References).
Function TotalWorkDays(Optional category As String = vbNullString) As Long
Dim lastRow As Long
With Sheet1
lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
Dim usedDates As Scripting.Dictionary
Set usedDates = New Scripting.Dictionary
Dim r As Long
'Loop through each row with date ranges.
For r = 8 To lastRow
Dim day As Long
'Loop through each day.
For day = .Cells(r, 4).Value To .Cells(r, 5).Value
'Check to see if the day is already in the Dictionary
'and doesn't fall on a weekend.
If Not usedDates.Exists(day) And Weekday(day, vbMonday) < 6 _
And (.Cells(r, 1).Value = category Or category = vbNullString) Then
'Haven't encountered the day yet, so add it.
usedDates.Add day, vbNull
End If
Next day
Next
End With
'Return the count of unique days.
TotalWorkDays = usedDates.Count
End Function
Note that this will work for any arbitrary category found in column 1, or all categories combined if it isn't passed an argument. Sample usage:
Sub Usage()
Debug.Print TotalWorkDays("HET") 'Sample data prints 55
Debug.Print TotalWorkDays("FRJ") 'Sample data prints 69
Debug.Print TotalWorkDays 'Sample data prints 69
End Sub
You can convert this to late bound (and skip adding the reference) by replacing these two lines...
Dim usedDates As Scripting.Dictionary
Set usedDates = New Scripting.Dictionary
...with:
Dim usedDates As Object
Set usedDates = CreateObject("Scripting.Dictionary")
I think if I were doing this, I'd use the Collection object, as it'd save converting names and dates to index id's.
You could create a main collection of names and, for each name, a sub collection of dates whose key is Excel's date serial number. This would make it easy to store the 'used days' and you could either acquire the total day count by using the .Count property or loop through the collection to aggregate a specific Oppgave.
The code would be straight forward as shown below. You could just put this in a module:
Option Explicit
Private mNames As Collection
Public Sub RunMe()
ReadValues
'Get the total days count
Debug.Print GetDayCount("FRJ")
'Or get the days count for one Oppgave
Debug.Print GetDayCount("FRJ", "Malfil tegning form")
End Sub
Private Sub ReadValues()
Dim v As Variant
Dim r As Long, d As Long
Dim item As Variant
Dim dates As Collection
With Sheet1
v = .Range(.Cells(8, "A"), .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 5).Value2
End With
Set mNames = New Collection
For r = 1 To UBound(v, 1)
'Acquire the dates collection for relevant name
Set dates = Nothing: On Error Resume Next
Set dates = mNames(CStr(v(r, 1))): On Error GoTo 0
'Create a new dates collection if it's a new name
If dates Is Nothing Then
Set dates = New Collection
mNames.Add dates, CStr(v(r, 1))
End If
'Add new dates to the collection
For d = v(r, 4) To v(r, 5)
On Error Resume Next
dates.Add v(r, 2), CStr(d)
On Error GoTo 0
Next
Next
End Sub
Private Function GetDayCount(namv As String, Optional oppgave As String) As Long
Dim dates As Collection
Dim v As Variant
Set dates = mNames(namv)
If oppgave = vbNullString Then
GetDayCount = dates.Count
Else
For Each v In dates
If v = oppgave Then GetDayCount = GetDayCount + 1
Next
End If
End Function
Dictionary approach should be the fastest.
But if your data are not that big you may want to adopt a "string" approach like follows
Function CountWorkingDays(key As String) As Long
Dim cell As Range
Dim iDate As Date
Dim workDates As String
On Error GoTo ExitSub
Application.EnableEvents = False
With Sheet1
With .Range("E7", .Cells(.Rows.Count, "A").End(xlUp))
.AutoFilter field:=1, Criteria1:=key
For Each cell In Intersect(.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible), .Columns(1))
For iDate = cell.Offset(, 3) To cell.Offset(, 4)
If Weekday(iDate, vbMonday) < 6 Then
If InStr(workDates, cell.value & iDate) <= 0 Then workDates = workDates & cell.value & iDate
End If
Next iDate
Next cell
End With
End With
CountWorkingDays = UBound(Split(workDates, key))
ExitSub:
Sheet1.AutoFilterMode = False
Application.EnableEvents = True
End Function
that you can use in your code as follows
sht2.Cells(2, 7) = CountWorkingDays("FRJ")
sht2.Cells(2, 8) = CountWorkingDays("HET")
As far as I know there is no direct formula to get overlap dates. My approach will be different from yours.
For each unique value in rng_FRJ_HET (i.e. only FRJ and HET as per e.g.)
Create an array with first date and last date
Mark array index with 1 for each date in range start and end date
Sum the array to get actual number of days
Next
So if the dates are repeated still they will mark as 1 in the array for that date.
=====================Added the code=== This will do for any number of names.
Option Explicit
Dim NameList() As String
Sub Overlapping_WorkDays()
Dim rng_FRJ_HET As Range
Dim cell_name As Range
Dim startDateRng As Range
Dim endDateRng As Range
Dim uniqueNames As Range
Dim stDate As Variant
Dim edDate As Variant
Dim Dates() As Integer
Set rng_FRJ_HET = Sheet1.Range("A8", Sheet1.Range("A8").End(xlDown))
Set startDateRng = Sheet1.Range("D8", Sheet1.Range("D8").End(xlDown))
Set endDateRng = Sheet1.Range("E8", Sheet1.Range("E8").End(xlDown))
stDate = Application.WorksheetFunction.Min(startDateRng)
edDate = Application.WorksheetFunction.Max(endDateRng)
ReDim NameList(0)
NameList(0) = ""
For Each cell_name In rng_FRJ_HET
If IsNewName(cell_name) Then
ReDim Dates(stDate To edDate + 1)
MsgBox cell_name & " worked for days : " & CStr(GetDays(cell_name, Dates))
End If
Next cell_name
End Sub
Private Function GetDays(ByVal searchName As String, ByRef Dates() As Integer) As Integer
Dim dt As Variant
Dim value As String
Dim rowIndex As Integer
Const COL_NAME = 1
Const COL_STDATE = 4
Const COL_EDDATE = 5
Const ROW_START = 8
Const ROW_END = 19
With Sheet1
For rowIndex = ROW_START To ROW_END
If searchName = .Cells(rowIndex, COL_NAME) Then
For dt = .Cells(rowIndex, COL_STDATE).value To .Cells(rowIndex, COL_EDDATE).value
Dates(CLng(dt)) = 1
Next
End If
Next
End With
GetDays = WorksheetFunction.Sum(Dates)
End Function
Private Function IsNewName(ByVal searchName As String) As Boolean
Dim index As Integer
For index = 0 To UBound(NameList)
If NameList(index) = searchName Then
IsNewName = False
Exit Function
End If
Next
ReDim Preserve NameList(0 To index)
NameList(index) = searchName
IsNewName = True
End Function
I am trying to make edge relation from excel file which are organized in rows,
A,B,C,
D,E
the aim is to create relationships from each row:
A,B
A,C
B,C
I have the following codes , the problem is the codes is efficient when rows are equal in length but for example for above rows it create also following edges (relationship):
D," "
E, " "
Which create big problem for large data set. I was wondering if some body can help me to adjust the code the way to create the edge list only till filled cells in each row. If there is any other way to do this more efficient will appreciate it.
Thank you so much,Will be great help.
My code:
Sub Transform()
Dim targetRowNumber As Long
targetRowNumber = Selection.Rows(Selection.Rows.Count).Row + 2
Dim col1 As Variant
Dim cell As Range
Dim colCounter As Long
Dim colCounter2 As Long
Dim sourceRow As Range: For Each sourceRow In Selection.Rows
For colCounter = 1 To Selection.Columns.Count - 1
col1 = sourceRow.Cells(colCounter).Value
For colCounter2 = colCounter + 1 To Selection.Columns.Count
Set cell = sourceRow.Cells(, colCounter2)
If Not cell.Column = Selection.Column Then
Selection.Worksheet.Cells(targetRowNumber, 1) = col1
Selection.Worksheet.Cells(targetRowNumber, 2) = cell.Value
targetRowNumber = targetRowNumber + 1
End If
Next colCounter2
Next colCounter
Next sourceRow
End Sub
I've played around with it - this should do the trick. We can probably speed it up by outputting to another variant array if needed, but this ran pretty quickly for me:
Sub Transform_New()
Dim rngSource As Range, rngDest As Range
Dim varArray As Variant
Dim i As Integer, j As Integer, k As Integer
Set rngSource = Sheet1.Range("A1", Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1)) 'Put all used rows into range
Set rngDest = Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1).Offset(2, 0) 'Set target range to start 2 below source range
varArray = Range(rngSource, rngSource.Offset(0, Range("A1").SpecialCells(xlCellTypeLastCell).Column)).Value
For i = LBound(varArray, 1) To UBound(varArray, 1) 'Loop vertically through array
For j = LBound(varArray, 2) To UBound(varArray, 2) 'Loop horizontally through each line apart from last cell
k = j
Do Until varArray(i, k) = ""
k = k + 1
If varArray(i, k) <> "" Then
rngDest.Value = varArray(i, j)
rngDest.Offset(0, 1).Value = varArray(i, k)
Set rngDest = rngDest.Offset(1, 0)
End If
Loop
Next
Next
End Sub