I've got to copy one cell at a time to rearrange the columns from a specific row based on a value in that row. This code worked perfectly copying from one sheet to another sheet within one workbook. Now I have tried to expand it to copy between workbooks. I cannot for the life of me get it to work. Any help would be appreciated. Ps) Some code removed to simplify
Dim bomWB As Workbook
Set bomWB = ThisWorkbook
strFullname = ("C:\Users\AlexA\Desktop\") & PartNo
Workbooks.Add.SaveAs Filename:=strFullname ', FileFormat:=xlcsv
Dim NewWB As Workbook
Set NewWB = ThisWorkbook
bomWB.Activate
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim R As Long
Dim L As Long
I = Worksheets("Main BOM").UsedRange.Rows.Count
Set xRg = Worksheets("Main BOM").Range("H2:H" & I)
On Error Resume Next
'Application.ScreenUpdating = False
For L = 1 To xRg.Count
If CStr(xRg(L).Value) = "0" Then GoTo Skip
R = R + 1
Workbooks(bomWB).Worksheets("Main BOM").Range("H" & L + 1).Copy _
Destination:=Workbooks(NewWB).Worksheets("Sheet1").Range("A" & R + 1)
Skip:
Next
Dim bomWB As Workbook
Set bomWB = ThisWorkbook
strFullname = ("C:\Users\AlexA\Desktop\") & PartNo
Workbooks.Add
Dim NewWB As Workbook
Set NewWB = ActiveWorkbook
bomWB.Activate
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim R As Long
Dim L As Long
I = Worksheets("Main BOM").UsedRange.Rows.Count
Set xRg = Worksheets("Main BOM").Range("H2:H" & I)
On Error Resume Next
'Application.ScreenUpdating = False
For L = 1 To xRg.Count
If CStr(xRg(L).Value) = "0" Then GoTo Skip
R = R + 1
bomWB.Worksheets("Main BOM").Range("H" & L + 1).Copy _
Destination:=NewWB.Worksheets("Sheet1").Range("A" & R + 1)
Skip:
Next
NewWB.SaveAs Filename:=strFullname, FileFormat:=xlCSV
NewWB.Close
Related
I have multiple workbooks in a folder and i need to copy paste data from some of them based on naming convention. I am copy pasting data based on column names to a master sheet as order of columns in source files is not the same. Code pasted below does the task but it looks for exact match in column names and as a result i am only able to capture 80% of the data as few column names in source files are not an exact match. For eg: A column in the Target file with header Premium is mentioned as Premium # 25% in the Source file. This is just an example.
Sub ImportExcelfiles()
Dim strPath As String
Dim strFile As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim bookName As Worksheet
Dim rowCountSource As Long
Dim colCountSource As Long
Dim rowOutputTarget As Long
Dim colOutputTarget As Long
Dim found1 As Range, found2 As Range, j As Long, Cr1 As String, srcRow As Range
'Variables for Sheet - Workbook Name
Dim nameCount As Long
Dim fileName As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'====================================
'SET THE PATH AND FILE TO THE FOLDER
'====================================
strPath = ThisWorkbook.Worksheets("Control").Range("C4")
fileName = ThisWorkbook.Worksheets("Control").Range("C5")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'set the target worksheet
Set wsTarget = ThisWorkbook.Worksheets("Master Data")
Set bookName = ThisWorkbook.Worksheets("Workbook Name")
'set the initial output row and column count for master data and workbook name
nameCount = 2
rowOutputTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop throught the excel files in the folder
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile)
Set wsSource = wbSource.Worksheets("Details")
'get the row and column counts
With wsSource
colCountSource = .Cells(2, Columns.Count).End(xlToLeft).Column
For j = 1 To colCountSource
Cr1 = .Cells(2, j).Value
Set srcRow = .Range("A2", .Cells(1, colCountSource))
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=True)
If Not found1 Is Nothing Then
colCountSource = wsTarget.Cells(1, Columns.Count).End(xlToLeft).Column
Set srcRow = wsTarget.Range("A1", wsTarget.Cells(1, colCountSource))
Set found2 = srcRow.Find(What:=Cr1, LookAt:=xlWhole, MatchCase:=F)
If Not found2 Is Nothing Then
rowCountSource = .Cells(Rows.Count, found1.Column).End(xlUp).Row
.Range(.Cells(3, found1.Column), .Cells(rowCountSource, found1.Column)).Copy
found2.Offset(rowOutputTarget, 0).PasteSpecial Paste:=xlPasteValues
End If
End If
Next j
End With
bookName.Range("A" & nameCount).Value = wbSource.Name
'update output row '2+12-1=13
nameCount = nameCount + 1
rowOutputTarget = rowOutputTarget + rowCountSource - 2
'close the opened workbook
wbSource.Close SaveChanges:=False
End If
'get the next file
strFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation
End Sub
This code takes approximately 5 mins to copy paste data. Is there a way to optimise it and also solve my problem of missing 20% data.
Because the target column name is the shorter you need to search the source column names for each target column name.
Option Explicit
Sub ImportExcelfiles()
Dim strPath As String, strFile As String, fileName As String
Dim wbSource As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim bookName As Worksheet
Dim rowCountSource As Long, colCountSource As Long
Dim colCountTarget As Long
Dim rowOutputTarget As Long, colOutputTarget As Long
Dim found1 As Range, found2 As Range, j As Long
Dim Cr1 As String, srcRow As Range
'Variables for Sheet - Workbook Name
Dim nameCount As Long
Dim t0 As Single: t0 = Timer
strPath = ThisWorkbook.Worksheets("Control").Range("C4")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
fileName = ThisWorkbook.Worksheets("Control").Range("C5")
'set the target worksheet
With ThisWorkbook
Set wsTarget = .Sheets("Master Data")
Set bookName = .Sheets("Workbook Name")
End With
'set the initial output row and column count
'for master data and workbook name
nameCount = 2
Dim arTarget, rngSrc As Range, rngTarget As Range
Dim lastrow As Long, n As Long
With wsTarget
rowOutputTarget = 1 + .Cells(.Rows.Count, 1).End(xlUp).Row
' array of target column names
colCountTarget = .Cells(1, .Columns.Count).End(xlToLeft).Column
arTarget = .Cells(1, 1).Resize(, colCountTarget)
End With
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop throught the excel files in the folder
Application.ScreenUpdating = False
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile, ReadOnly:=True)
Set wsSource = wbSource.Worksheets("Details")
With wsSource
'get the row and column counts'get the row and column counts
colCountSource = .Cells(2, Columns.Count).End(xlToLeft).Column
Set srcRow = .Range("A2", .Cells(1, colCountSource))
' loop through target columns
For j = 1 To UBound(arTarget, 2)
Cr1 = arTarget(1, j)
Set found1 = srcRow.Find(What:=Cr1, LookAt:=xlPart, MatchCase:=True)
' found
If Not found1 Is Nothing Then
rowCountSource = .Cells(.Rows.Count, found1.Column).End(xlUp).Row
n = rowCountSource - 2
Set rngSrc = .Range(.Cells(3, found1.Column), .Cells(rowCountSource, found1.Column))
Set rngTarget = wsTarget.Cells(rowOutputTarget, j)
rngTarget.Resize(n).Value2 = rngSrc.Value2
If lastrow < rowOutputTarget + n Then
lastrow = rowOutputTarget + n
End If
End If
Next
End With
bookName.Range("A" & nameCount).Value = wbSource.Name
'update output row '2+12-1=13
nameCount = nameCount + 1
rowOutputTarget = lastrow
'close the opened workbook
wbSource.Close SaveChanges:=False
End If
'get the next file
strFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
My Master Report in fold.xlsm has a range of file and corresponding worksheets with tab names that correspond to the client and the type of data on that tab (indicated by variables xWs_Tax, xWs_Ins, etc.)
After storing these it then opens the corresponding client workbook.(replaced with fname.xlsx below)
The code is supposed to delete all worksheets NOT matching these stored names that include the client number in them. But I can't seem to get it to work. Either it deletes all the tabs or it does nothing at all depending on how I fiddle with it. Does anything jump out at you below or am I using bad code maybe? Do I need to do more then just declare Dim xWs As Worksheet ?
Here is where the variables are stored:
Dim xWs_ins As String
Dim xWs_tax As String
Dim xWs_ucc As String
Dim xWs_loc As String
Dim rc As String
rc = Range("P40")
For i = 41 To (rc + 40)
Workbooks("Master Report in fold.xlsm").Activate
MsgBox$ Range("J" & i)
xWs_ins = Range("J" & i)
xWs_tax = Range("K" & i)
xWs_ucc = Range("L" & i)
xWs_loc = Range("M" & i)
Workbooks.Open filename:= for example "20 Investor Certification - Master Servicers.xlsx
Dim xWs As Worksheet
'' Application.ScreenUpdating = False
'' Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook
If xWs.Name <> xWs_ins And xWs.Name <> xWs_tax And xWs.Name <> xWs_ucc And xWs.Name <> xWs_loc Then
xWs.Delete
End If
Next
'' Application.DisplayAlerts = True
'' Application.ScreenUpdating = True
ActiveWorkbook.Save
Next i
Delete Unwanted Sheets
There are unclear 'items' addressed in OP's comments and marked with ??? in the code.
Option Explicit
Sub deleteUnwanted()
Dim swb As Workbook: Set swb = Workbooks("Master Report in fold.xlsm")
' The worksheet name is unknown??? ("Sheet1")
Dim sws As Worksheet: sws = swb.Worksheets("Sheet1")
Dim sCell As Range
Dim srg As Range
Dim dwb As Workbook
Dim dsh As Object ' There is no 'Sheet' object.
Dim dArr As Variant
Dim dshCount As Long
' The workbook and worksheet are unknown??? (sws)
Dim rc As String: rc = sws.Range("P40").Value
Application.ScreenUpdating = False
For i = 41 To (rc + 40)
n = 0
Set sCell = sws.Cells(i, "I")
Set dwb = Workbooks.Open(sCell.Value)
dshCount = dwb.Sheets.Count
ReDim dArr(1 To dshCount)
Set srg = sws.Columns("J:M").Rows(i)
For Each dsh In dwb.Sheets
If IsError(Application.Match(dsh.Name, srg, 0)) Then
n = n + 1
dArr(n) = dsh.Name
End If
Next
If n > 0 Then
ReDim Preserve dArr(1 To n)
Application.DisplayAlerts = False
dwb.Worksheets(dArr).Delete
Application.DisplayAlerts = True
End If
dwb.Close SaveChanges:=True
Next i
Application.ScreenUpdating = True
End Sub
I've only been at VBA for about 2 weeks so I need some assistance. I have a loop setup to copy 7 cells across on workbook (A), then paste them vertically in a column on workbook (B). For some reason the code is working but will not paste any data... I've been trying to troubleshoot for a while now with no luck.
Here is a screenshot of the sheet I'm copying data from.
Here is a screenshot of the workbook I'm pasting too.
Sub pullSecEquipment()
Dim path As String
Dim ThisWB As String
Dim wbDest As Workbook
Dim shtDest As Worksheet
Dim Filename As String
Dim Wkb As Workbook
Dim CopyRng As Range, DestRng As Range
Dim lRow As Integer
Dim destLRow As Integer
Dim UpdateDate As String
ThisWB = ActiveWorkbook.Name
Dim selectedFolder
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
selectedFolder = .SelectedItems(1) & "\"
End With
path = selectedFolder
Application.EnableEvents = False
Application.ScreenUpdating = False
Set shtDest = Workbooks("GPnewchapterTEST2.xlsm").Worksheets("START")
'clear content of destination table
shtDest.Rows("8:" & Rows.Count).ClearContents
Filename = Dir(path & "\*.xls*", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
'MsgBox Filename
'''''
'SEC
'''''
If InStr(Filename, "Equipment") <> 0 Then
'''
'' Equipment Hours
'''
Dim range1 As Range
Set range1 = Range("E:K")
If shtDest.Name Like "*-*" Then
'last row
destLRow = Wkb.Sheets(1).Cells.Find(what:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
'1st row
lRow = Wkb.Sheets(1).Cells.Find(what:="EQUIPMENT DESCRIPTION", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
Dim i As Integer
For i = lRow To destLRow
Set CopyRng = Wkb.Sheets(1).Range(Cells(i, 5).Address, Cells(i, 11).Address)
Set DestRng = shtDest.Range("O" & shtDest.Cells(Rows.Count, 1).End(xlUp).Row + 1)
CopyRng.Copy
DestRng.PasteSpecial Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard
i = i + 2
Next i
End If
End If
Filename = Dir()
Loop
MsgBox "Done!"
End Sub
I'm not experienced with VBA, but I think it's the only way for this to work.
I need to send a report to each sales team, but don't want to send them the information of other sales team. There are multiple sheets per workbook with different reports which all have a sales team column.
I would like all the sheets to be filtered by sales team, and create a new workbook for each team.
I appreciate any help.
I got this solution.
Just send me an email if you need this solution.
At first I got this format:
I create the following macro code
Option Explicit
Dim MainWorkBook As Workbook
Dim NewWorkBook As Workbook
Sub ExportWorksheet()
Dim Pointer As Long
Set MainWorkBook = ActiveWorkbook
Range("E2").Value = MainWorkBook.Sheets.Count
Application.ScreenUpdating = False 'enhance the performance
For Pointer = 2 To MainWorkBook.Sheets.Count
Set NewWorkBook = Workbooks.Add
MainWorkBook.Sheets(Pointer).Copy After:=NewWorkBook.Sheets(1)
Application.DisplayAlerts = False
NewWorkBook.Sheets(1).Delete
Application.DisplayAlerts = True
With NewWorkBook
.SaveAs Filename:="C:\Users\lengkgan\Desktop\Testing\" & MainWorkBook.Sheets(Pointer).Name & ".xls" 'you may change to yours
End With
NewWorkBook.Close SaveChanges:=True
Next Pointer
Application.ScreenUpdating = True
Range("D5").Value = "Export Completed"
End Sub
Following is the output
I have written a VBA(Macro) program which will work based on Input data. All you need to do is, provide input data in a column in another sheet. Macro will read the data and filter Master Sheet based on each row then it Generate new excel sheet based on find data.
enter Option Explicit
Dim personRows As Range 'Stores all of the rows found
'Split data into separate columns baed on the names defined in
'a RepList on the 'Names' sheet.
Sub SplitSalesData()
Dim wb As Workbook
Dim p As Range
Dim counter2 As Integer
Dim i As Integer
counter2 = 0
i = 0
Application.ScreenUpdating = False
' in my case i am generating new excel based on every 8 reacords from begining. You can simplyfy this logic based on your need.
For Each p In Sheets("Names").Range("RepList") ' Give the name of your input sheet and column
If i = 0 Then ' We are starting, so generate new excel in memeory.
Workbooks.Add
Set wb = ActiveWorkbook
ThisWorkbook.Activate
End If
WritePersonToWorkbook wb, p.Value
i = i + 1 ' Increment the counter reach time
If i = 8 Then ' As my need is after processing every 8 uniqe record just save the excel sheet and reset the processing
counter2 = counter2 + 1
wb.SaveAs ThisWorkbook.Path & "\salesdata_" & CStr(counter2) ' save the data at current directory location.
wb.Close
Set personRows = Nothing ' Once the process has completed for curent excelsheet, set the personRows as NULL
i = 0
End If
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
'Writes all the data rows belonging to a RepList
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
ByVal Person As String)
Dim rw As Range
Dim firstRW As Range
For Each rw In UsedRange.Rows
If Not Not firstRW Is Nothing And Not IsNull(rw) Then
Set firstRW = rw ' WE want to add first row in each excel sheet.
End If
If Person = rw.Cells(1, 5) Then ' My filter is working based on "FeederID"
If personRows Is Nothing Then
Set personRows = firstRW
Set personRows = Union(personRows, rw)
Else
Set personRows = Union(personRows, rw)
End If
End If
Next rw
personRows.Copy SalesWB.Sheets(1).Cells(1, 1) ' Adding data in Excel sheet.
End Sub
please find below code
Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim icol As Long
Dim l As Long
Dim headercol As Long
Dim stroutputfolder As String
stroutputfolder = "D:\Ba"
'dim str
icol = 1
headercol = 3
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
For nRow = headercol + 1 To nLastRow
'Get the specific Column
'Here my instance is "B" column
'You can change it to your case
strColumnValue = objWorksheet.Cells(nRow, icol).Value
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
Next
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
'MsgBox (varColumnValues(i))
If Dir(stroutputfolder, vbDirectory) = vbNullString Then MkDir stroutputfolder
If CStr(varColumnValue) <> "" Then
objWorksheet.UsedRange.Offset(headercol - 1, 0).AutoFilter Field:=icol, Criteria1:=CStr(varColumnValue)
Set objExcelWorkbook = Excel.Application.Workbooks.Add
Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name
objWorksheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
'strFilename = strOutputFolder & "\" & strItem
ActiveWorkbook.SaveAs Filename:=stroutputfolder & "\" & CStr(varColumnValue) & ".xlsb", FileFormat:=50
ActiveWorkbook.Close savechanges:=False
l = l + 1
End If
Next
objWorksheet.ShowAllData
MsgBox (l & " files splitted")
End Sub
I am not sure why the range that i am selecting when a new work book is not being copied over. The workbook sheets are blank and i cant figure out why.
Sub NB()
Dim X
Dim copyRange
Dim lngCnt As Long
Dim strDT As String
Dim strNewBook As String
Dim objWS As Object
Dim WB As Workbook
Dim bNewBook As Boolean
Dim topRow As Integer
topRow = -1
Set objWS = CreateObject("WScript.Shell")
strDT = objWS.SpecialFolders("Desktop") & "\Book1"
If Len(Dir(strDT, vbDirectory)) = 0 Then
MsgBox "No such directory", vbCritical
Exit Sub
End If
X = Range([f1], Cells(Rows.Count, "f").End(xlUp)).Value2
For lngCnt = 1 To UBound(X, 1)
If Len(X(lngCnt, 1)) > 0 Then
If (topRow = -1) Then
topRow = lngCnt
Else
If Not bNewBook Then
'make a single sheet workbook for first value
Set WB = Workbooks.Add(1)
copyRange = Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Value2
'find a way to copy copyRange into WB
Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Select
Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Copy
Range("A1").PasteSpecial
WB.SaveAs strDT & "\" & X(topRow, 1) & ".xls"
strNewBook = WB.FullName
WB.Close
bNewBook = True
Else
Set WB = Workbooks.Add(1)
copyRange = Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Value2
'find a way to copy copyRange into WB
Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Select
Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Copy
Range("A1").PasteSpecial
WB.SaveAs strDT & "\" & X(topRow, 1) & ".xls"
WB.Close
End If
topRow = lngCnt
End If
End If
Next
Set WB = Workbooks.Add(1)
When you create the new workbook it becomes active, so referring to ranges occurs in this new book, copying empty cells.
You need a reference to the current workbook
Dim wbCurrent As Workbook
Set wbCurrent = ThisWorkbook 'or ActiveWorkbook
Get references to the corresponding Worksheet(s) as well, then begin every Range or Cells use with a reference to the correct worksheet object-variable.
Dim wbCurrent As Workbook
Dim wsNew As Worksheet
Dim wsCurrent As Worksheet
Set wbCurrent = ThisWorkbook
Set wsCurrent = wbCurrent.Worksheets("Whatever Name")
Set WB = Workbooks.Add(1)
Set wsNew = WB.Worksheets(1)
You can go a step further and create object-variables to refer to ranges (of the different worksheets) as well. It may seem like overkill, but you need to clearly distinguish which workbook (worksheet, etc.) you are using. It will make your code easier to follow in the longer term as well.
Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Select
Range(Cells(topRow, "f"), Cells(lngCnt, 12).End(xlUp)).Copy
Range("A1").PasteSpecial
Is selecting and copying empty data from the new workbook to the same empty workbook
I found that it's not just a question of setting the active worksheet. The range property of the "Copy" method doesn't work if the source sheet is no longer active. In order to get this to work I had to go to simply copying the values in code without using copy and replace.
I found the original code hard to follow, so I tweaked it a little. Here is what I ended up with. This should sub-divide the spreadsheet based on captions in F and copy the data in G - M to output columns A - G
Sub NB()
Dim strDT As String
Dim WB As Workbook
Dim Ranges(10) As Range
Dim Height(10) As Integer
Dim Names(10) As String
Dim row As Long
Dim maxRow As Long
Dim top As Long
Dim bottom As Long
Dim iData As Integer
Dim iBook As Long
Set objWS = CreateObject("WScript.Shell")
strDT = objWS.SpecialFolders("Desktop") & "\Book1"
If Len(Dir(strDT, vbDirectory)) = 0 Then
MsgBox "No such directory", vbCritical
Exit Sub
End If
iData = 0
maxRow = Range("G" & 65536).End(xlUp).row
If (maxRow < 2) Then
MsgBox ("No Data was in the G column")
Exit Sub
End If
' The first loop stores the source ranges
For row = 1 To maxRow
If (Not IsEmpty(Range("F" & row))) Then
If (iData > 0) Then
Set Ranges(iData) = Range("G" & top & ":" & "M" & bottom)
Height(iData) = bottom - top
End If
iData = iData + 1
top = row + 1
bottom = row + 1
Names(iData) = Range("F" & row).Value2
Else
bottom = row + 1
End If
Next
Set Ranges(iData) = Range("G" & top & ":" & "M" & bottom)
Height(iData) = bottom - top
' The second loop copies the values to the output ranges.
For iBook = 1 To iData
'make a single sheet workbook for first value
Set WB = Workbooks.Add(1)
Range("A1:G" & Height(iBook)).Value = Ranges(iBook).Value2
WB.SaveAs (strDT & "\" & Names(iBook) & ".xls")
WB.Close
Next
End Sub
Function IsEmpty(ByVal copyRange As Range)
IsEmpty = (Application.CountA(copyRange) = 0)
End Function