In the given image, I have Project names and their start and end dates. I want to write a VBA code such that the End date is highlighted green if there is a difference of less than equal to 3 months between start and end date. Also, I want to be able to do this by using the Column header name as the column placement might change in the future. Therefore, I do not want to use conditional formatting but VBA code to write a dynamic code which works based on Column header name.
Any help is appreciated. Thanks in advance!
How about something like below (this assumes that by 3 months you mean 90 days):
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your Sheet above, change Sheet1 as required
Dim FoundStart As Range
Dim FoundEnd As Range
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the number of rows with data from Column A
Set FoundStart = ws.Rows(1).Find(What:="Start") 'find the header with "Start"
Set FoundEnd = ws.Rows(1).Find(What:="End") 'find the header with "End"
If Not FoundStart Is Nothing And Not FoundEnd Is Nothing Then 'if both headers are found then
For i = 2 To LastRow 'loop from row 2 to last
If ws.Cells(i, FoundStart.Column) - ws.Cells(i, FoundEnd.Column) <= 90 Then ' if the difference between start and end is less or equal to 90 days
ws.Cells(i, FoundEnd.Column).Interior.ColorIndex = 4 'highlight End in Green
End If
Next i
Else
MsgBox "Headers Not found!", vbInformation
End If
End Sub
UPDATE
If instead of 90 days you want to highlight the rows where the month difference is 3 or less then something like this will do it:
Sub foo2()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your Sheet above, change Sheet1 as required
Dim FoundStart As Range
Dim FoundEnd As Range
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the number of rows with data from Column A
Set FoundStart = ws.Rows(1).Find(What:="Start") 'find the header with "Start"
Set FoundEnd = ws.Rows(1).Find(What:="End") 'find the header with "End"
If Not FoundStart Is Nothing And Not FoundEnd Is Nothing Then 'if both headers are found then
For i = 2 To LastRow 'loop from row 2 to last
MonthDiff = DateDiff("m", ws.Cells(i, FoundStart.Column), ws.Cells(i, FoundEnd.Column))
If MonthDiff <= 3 Then
ws.Cells(i, FoundEnd.Column).Interior.ColorIndex = 4 'highlight End in Green
End If
Next i
Else
MsgBox "Headers Not found!", vbInformation
End If
End Sub
Related
I'm having the following columns in Excel: Document Date (all cells have values) & Initial Disposition Date (there're blanks within the column).
Each Document Date cell corresponds to an Initial Disposition Date cell.
For any blank Initial Disposition Date cells, I'd like to set them to be 7 days from the corresponding Document Date. (Strictly blank cells)
Ex: Document Date = 10/01/2018. Desired Initial Disposition Date = 10/08/2018.
Is there a code to execute such action? (I have approximately 55,000 rows and 51 columns by the way).
Thank you very much! Any suggestions or ideas are highly appreciated!
Looping through a range is a little quicker in this case. I am assuming your data is on Sheet1, your Document Date is on Column A and your Initial Deposition is on Column B.
Last, you need to determine if you want that 7 days to be inclusive of weekends or not. I left you a solution for both. You will need to remove one of the action statements (in middle of loop)
Option Explicit
Sub BetterCallSaul()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LRow As Long, iRange As Range, iCell As Range
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set iRange = ws.Range("B2:B" & LRow)
Application.ScreenUpdating = False
For Each iCell In iRange
If iCell = "" Then
iCell = iCell.Offset(, -1) + 7 'Includes Weekends
iCell = WorksheetFunction.WorkDay(iCell.Offset(, -1), 7) 'Excludes Weekends
End If
Next iCell
Application.ScreenUpdating = True
End Sub
If your Document Date is on Column A and you Initial Disposition Date in Column B, then the following would achieve your desired results:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
Lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For i = 2 To Lastrow
'loop from row 2 to the last row with data
If ws.Cells(i, "B").Value = "" Then
'if there is no value in Column B then
ws.Cells(i, "B").Value = ws.Cells(i, "A").Value + 7
'add seven days to the date from Column A
End If
Next i
End Sub
A formula on all blanks would avoid the delays looping through the worksheet column(s).
Sub ddPlus7()
Dim dd As Long, didd As Long
With Worksheets("sheet1")
'no error control on the next two lines so those header labels better be there
dd = Application.Match("Document Date", .Rows(1), 0)
didd = Application.Match("Desired Initial Disposition Date", .Rows(1), 0)
On Error Resume Next
With Intersect(.Columns(dd).SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow, _
.Columns(didd).SpecialCells(xlCellTypeBlanks).EntireRow, _
.Columns(didd))
.FormulaR1C1 = "=rc[" & dd - didd & "]+7"
End With
On Error GoTo 0
End With
End Sub
I have 10 sheets in a workbook - These sheets were imported from individual workbooks - These workbooks were extracts from different monitoring tools
I need to apply a filter across all 10 worksheets, however, not all the sheets are in the same format/structure.
With 6 of the worksheets, the column headers are the same and in the same order.
The remaining 4 sheets have different headers. For example: The filter needs to look for a header name Status - This works for the 6 sheets that have the same structure, however, the other 4 sheets have the following:
wsheet1:
User Status instead of Status - I need to change the header to Status
wsheet2:
Current_Status instead of Status - I need to change the header to Status
Below is sample code that is supposed to manipulate the specified sheet in in order to have it "look" the same as the others, however, I am having some really annoying issues where the code isn't applied to the sheet specified and is instead applied to the "Activesheet" when the macro is executed.
Here is the code I have:
Sub arrangeSheets()
Dim lastCol As Long, idCount As Long, nameCount As Long, headerRow As Long
Dim worksh As Integer, WS_Count As Integer, i As Integer, count As Integer
Dim rng As Range, cel As Range, rngData As Range
Dim worksheetexists As Boolean
worksh = Application.Sheets.count
worksheetexists = False
headerRow = 1 'row number with headers
lastCol = Cells(headerRow, Columns.count).End(xlToLeft).Column 'last column in header row
idCount = 1
nameCount = 1
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.count
'If Application.Match finds no match it will throw an error so we need to skip them
On Error Resume Next
For x = 1 To worksh
If Worksheets(x).Name = "wsheet1" Then
worksheetexists = True
Set rng = Sheets("wsheet1").Range(Cells(headerRow, 1), Cells(headerRow, lastCol)) 'header range
With Worksheets("wsheet1").Name
Rows(2).Delete
Rows(1).Delete
count = Application.Match("*USER STATUS*", Worksheets("wsheet1").Range("A1:AZ1"), 0)
If Not IsError(count) Then
For Each cel In rng 'loop through each cell in header
If cel = "*USER STATUS*" Then 'check if header is "Unit ID"
cel = "STATUS" & idCount 'rename "Unit ID" using idCount
idCount = idCount + 1 'increment idCount
End If
Next cel
End If
End With
Exit For
End If
Next x
End Sub
Consider using ., in the With-End with section to refer to the Worksheet mentioned:
The Like in If cel Like "*USER STATUS*" works with the *, thus will be evaluated to True for 12USER STATUS12 or anything similar.
The count variable should be declared as variant, thus it can keep "errors" in itself.
This is how the code could look like:
With Worksheets("wsheet1")
.Rows(2).Delete
.Rows(1).Delete
Count = Application.Match("*USER STATUS*", .Range("A1:AZ1"), 0)
If Not IsError(Count) Then
For Each cel In Rng 'loop through each cell in header
If cel Like "*USER STATUS*" Then 'check if header is "Unit ID"
cel = "STATUS" & idCount 'rename "Unit ID" using idCount
idCount = idCount + 1 'increment idCount
End If
Next cel
End If
End With
If you want the same headers across all sheets in the workbook you could just copy the headers from the first sheet and paste them on each sheet.
This wouldn't work if your column order is different across sheets, but from the example you gave it's just renaming columns rather than re-ordering?
Sub CorrectHeaders()
Dim cpyRng As Range
With ThisWorkbook
If .Worksheets.count > 1 Then
With .Worksheets(1)
Set cpyRng = .Range(.Cells(1, 1), .Cells(1, .Columns.count).End(xlToLeft))
End With
.Sheets.FillAcrossSheets cpyRng
End If
End With
End Sub
If the column headers are in different orders, but you just want to replace any cell that contains the text "Status" with just "Status" then you could use Replace. You may want to add an extra condition of MatchCase:=True.
Sub Correct_Status()
Dim wrkSht As Worksheet
For Each wrkSht In ThisWorkbook.Worksheets
wrkSht.Cells(1, 1).EntireRow.Replace What:="*Status*", Replacement:="Status", LookAt:=xlWhole
Next wrkSht
End Sub
I have additional solution which has also helped with this issue. Code below:
Sub ManipulateSheets()
Dim worksh As Integer
Dim worksheetexists As Boolean
worksh = Application.Sheets.count
worksheetexists = False
'If Application.Match finds no match it will throw an error so we need to skip them
On Error Resume Next
Worksheets("wSheet1").Activate
With Worksheets("wSheet1")
.Rows(2).Delete
.Rows(1).Delete
End With
Worksheets("wSheet2").Activate
With Worksheets("wSheet2")
.Rows(2).Delete
End With
End Sub
I am new to VBA as a language, and I'm having issues sorting a large spreadsheet. The sheet is roughly 400,000 rows by 8 columns. The relevant data begins on row 5. In Column C, I changed the format of the date and rounded it down to give a single integer representing the day.
The goal is to find where the data changes days, and cut and paste all of that day's data to a seperate tab. The code I have written successfully does this for the first 2 days, but the 3rd iteration and beyond will not work properly. I have used a color code (blue) to represent the last row for each day, and I'm using this color change as my loop condition. The 3rd loop ignores the 1st color change and instead cuts and pastes 2 day's worth of data, and the 4th loop moves 3 days.
Would there be a more efficient way to move each day's data to a new tab? Each day represents 28800 rows by 6 columns. It should be noted that an additional macro is run before this in order to simply organize the raw data. The portion of the code giving me issues are the loops following the "Sort the data by date" comment.
Any help would be greatly appreciated! Thanks in advance. Attached is my code and a sample of the data
Sub HOBO_Split_v2()
'Before this code can be run, you must run "Hobo_Organize" 1 time. Press 'Ctrl + Shift + O' to do this
'The purpose of this code is to separate the hobo data by day. Weekends and evenings will be removed.
'This will create smaller data sets, which allows for easier data manipulation
Application.ScreenUpdating = False
'Find the last row
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
'Set the known parameters
Dim days As Range
Set days = Worksheets("Full Data Set").Range("C5:C" & Lastrow)
Dim daychanges As String
daychanges = 0
'Maximum of 3 weeks of data, 21 different sheets
Dim sheetnum(1 To 21) As Integer
For i = 1 To 21
sheetnum(i) = i
Next i
'Loop through the day index (Col C), counting the number of day changes
For Each cell In days
If cell.Value <> cell.Offset(1).Value Then
cell.Interior.ColorIndex = 37
daychanges = daychanges + 1
End If
Next cell
'Add new sheets for each day and rename the sheets
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Day 1"
For i = 2 To daychanges
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "Day " & sheetnum(i)
Next i
Sheets("Full Data Set").Select
'Sort the data by date
For Each cell In days
If cell.Interior.ColorIndex = 37 Then
cell.Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Worksheets(Worksheets.Count).Select
ActiveSheet.Range("B2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Move Before:=Sheets("Full Data Set")
Sheets("Full Data Set").Select
Range("C4").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlDown)).Select
Set days = Selection
End If
Next cell
Application.ScreenUpdating = True
End Sub
Example of the data
I'd not pass through any cell coloring and use RemoveDuplicates() method of Range object as like follows:
Option Explicit
Sub HOBO_Split_v2()
Dim datesRng As Range, dataRng As Range, cell As Range
Dim iDay As Long
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Full Data Set")
Set datesRng = .Range("C5", .Cells(.Rows.Count, 3).End(xlUp)) '<--| set dates range
Set dataRng = datesRng.offset(-1).Resize(datesRng.Rows.Count + 1, 6) '<--| set data range as dates one extended to next 5 columns
With datesRng.offset(, .UsedRange.Columns.Count) '<--| use a helper column out of current used range
.value = datesRng.value '<--| copy dates value in helper column
.RemoveDuplicates Columns:=Array(1) '<--| remove duplicates and have only unique values in helper column
For Each cell In .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) '<--| iterate through remaining (unique) day values in helper column
iDay = iDay + 1 '<--| update "current day" counter
dataRng.AutoFilter Field:=1, Criteria1:=Format(cell, "#.00") '<--| filter data by "current day", format the criteria as the actual column C cells format
dataRng.offset(1).Resize(dataRng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=SetWorkSheet(ThisWorkbook, "Day " & iDay).Range("B2") '<--| copy filtered data and paste the into "current day" corresponding sheet
Next cell
.Parent.AutoFilterMode = False '<--| remove autofilter
.Clear '<--| clear helper column
End With
End With
Application.ScreenUpdating = True
End Sub
Function SetWorkSheet(wb As Workbook, SheetName As String) As Worksheet
On Error Resume Next
Set SetWorkSheet = wb.Worksheets(SheetName)
On Error GoTo 0
If SetWorkSheet Is Nothing Then
Set SetWorkSheet = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
SetWorkSheet.Name = SheetName
Else
SetWorkSheet.UsedRange.Clear '<--| clear preceeding values in already existent sheet
End If
End Function
There is no need to iterate over the list twice. GetWorkSheet create the new worksheets for you if they don't exist and handle any errors.
Sub HOBO_Split_v2()
Application.ScreenUpdating = False
Dim cell As Range, days As Range
Dim lFirstRow As Long, Lastrow As Long
Dim SheetName As String
Dim ws As Worksheet
With Sheets("Full Data Set")
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
Set days = .Range("C5:C" & Lastrow)
For Each cell In days
If c.Text <> SheetName Or c.Row = Lastrow Then
If lFirstRow > 0 Then
Set ws = getWorkSheet(SheetName)
.Range("A" & lFirstRow, "A" & cell.Row).EntireRow.Copy ws.Range("A1")
End If
SheetName = c.Text
lFirstRow = i
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getWorkSheet(SheetName As String) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(SheetName)
If ws Is Nothing Then
Set ws = Worksheets.Add(after:=ActiveSheet)
ws.Name = SheetName
End If
On Error GoTo 0
Set getWorkSheet = ws
End Function
I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With
I have tried searching the internet for various answers to this question but cannot find the right answer. I have an Excel Workbook with worksheets represent each day of the month. In each of these sheets the format is the same (except on Saturdays and Sundays) and the sheets contain call stats. It is presented in the following format:
00:00 00:30 0 4 6 3 4 8 0 1 0 0 0
00:00 00:30 0 0 2 7 4 1 0 0 3 3 0
00:00 00:30 7 0 7 5 2 8 6 1 7 9 0
I need to copy this data into 1 single sheet that lists all the data. Basically it appends the new data on to the bottom of the old data. So it will be one big list.
How can this be done? All I can see is how to produce a total from multiple data by adding all the values together. I just need to list the data as one big list.
MASSIVE EDIT:
As with last chat with Iain, the correct parameters have been set. I have removed the last few code snippets as they are quite not right. If anyone is still interested, please check the edit history.
Hopefully, this is the final edit. ;)
So, the correct conditions needed are:
Month name in sheet. We used an Input Box for this.
We check for number of rows. There are three conditions: 157 rows total, 41 rows total, and all else.
The following subroutine will do the trick.
Sub BlackwoodTransfer()
Dim Summ As Worksheet, Ws As Worksheet
Dim ShName As String
Dim nRow As Long
Set Summ = ThisWorkbook.Sheets("Summary")
ShName = InputBox("Enter month for Call Flow in mmmm format (ie. November, etc.):") & " Call Flow"
'Returns November Call Flow. This means it will target every sheet that has November Call Flow in its name.
Application.ScreenUpdating = False
For Each Ws In ThisWorkbook.Worksheets
If InStr(1, Ws.Name, ShName) > 0 Then
'Starting from first character of the sheet's name, if it has November, then...
nRow = Summ.Cells(Rows.Count, 1).End(xlUp).Row + 1
'... get the next empty row of the Summary sheet...
Select Case Ws.Cells(Rows.Count, 1).End(xlUp).Row
'... check how many rows this qualified sheet has...
Case 157
'... if there are 157 rows total...
Ws.Range(Cells(57,1),Cells(104,13)).Copy
'... copy Rows 57 to 104, 13 columns wide...
Summ.Range("A" & nRow).PasteSpecial xlPasteAll
'... and paste to next empty row in Summary sheet.
Case 41
Ws.Range(Cells(23,1),Cells(126,13)).Copy
Summ.Range("A" & nRow).PasteSpecial xlPasteAll
Case Else
Ws.Range(Cells(23,1),Cells(30,13)).Copy
Summ.Range("A" & nRow).PasteSpecial xlPasteAll
End Select
End If
Next Ws
Application.ScreenUpdating = True
End Sub
#Iain: Check out the comments and cross reference them with the MSDN database. That should explain what each function/method is doing exactly. Hope this helps!
Sub CombineSheets()
Dim ws As Worksheet, wsCombine As Worksheet
Dim rg As Range
Dim RowCombine As Integer
Set wsCombine = ThisWorkbook.Worksheets.Add(ThisWorkbook.Worksheets(1))
wsCombine.Name = "Combine"
RowCombine = 1
For Each ws In ThisWorkbook.Worksheets
If ws.Index <> 1 Then
Set rg = ws.Cells(1, 1).CurrentRegion
rg.Copy wsCombine.Cells(RowCombine, 2)
wsCombine.Range(Cells(RowCombine, 1), Cells(RowCombine + rg.Rows.Count - 1, 1)) = ws.Name
RowCombine = RowCombine + rg.Rows.Count
End If
Next
wsCombine.Cells(1, 1).EntireColumn.AutoFit
Set rg = Nothing
Set wsCombine = Nothing
End Sub
Create a worksheet "Summary" which is to contain all the merged data.
Open ThisWorkBook (simply press ALT+F11 in your excel workbook. A new window will open. Your worksheet name will be visible on the left hand side. Keep expanding till you see ThisWorkBook)
Double click ThisWorkBook and add the following code in it:
Sub SummurizeSheets()
Dim ws As Worksheet
Application.Screenupdating = False
Sheets("Summary").Activate
For Each ws In Worksheets
If ws.Name <> "Summary" Then
ws.Range("F46:O47").Copy
ActiveSheet.Paste Range("A65536").End(xlUp).Offset(1, 0)
End If
Next ws
End Sub
Sub AddToMaster()
'this macro goes IN the master workbook
Dim wsMaster As Worksheet, wbDATA As Workbook
Dim NextRow As Long, LastRow As Long
Dim FileName As String
Dim FolderPath As String
Dim n As Long
Dim i
Set wsMaster = ThisWorkbook.Sheets("Sheet1")
'Specify the folder path
FolderPath = "D:\work\"
'specifying file name
FileName = Dir(FolderPath & "*.xls*")
Do While FileName <> ""
NextRow = wsMaster.Range("A" & Rows.Count).End(xlUp).Row + 1
Set wbDATA = Workbooks.Open(FolderPath & FileName)
With wbDATA.Sheets("product_details")
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
' If LastRow > 5 Then
For i = 2 To LastRow
.Range("A2:j" & i).Copy
wsMaster.Range("A" & NextRow).PasteSpecial xlPasteValues
'Set NextRow = NextRow
Next i
End With
FileName = Dir()
Loop
wbDATA.Close False
End Sub