i am stucked with a another problem hope anyone can help me out.
The code Below imports data from the text files into excel file .
i need to modify this tool in such a way that after row count in excel
sheet exceeds 5000 it has to import it in a new sheet .

Dim mobjFSO As FileSystemObject

Sub RunSafeway_DB_QC()
Dim strFolder As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder contains the Safeway DB QC Files"
strFolder = .Show
If strFolder < "0" Then
Call GetSnapShot(.SelectedItems(1))
End If
End With

End Sub

Private Sub GetNewUPC(ByVal FolderPath As String, _
ByVal Companion As String)

Dim strLine() As String
Dim objFile As Scripting.TextStream
Dim rngCell As Range
Dim intLine As Integer
Dim strText As String
Dim strPath As String

'strPath = ThisWorkbook.Path & "\"
'strPath = FolderPath & "\"
Set rngCell = ThisWorkbook.Names("NewUPC").RefersToRange
If Not IsEmpty(rngCell.Offset(1, 0)) Then
If Not IsEmpty(rngCell.Offset(2, 0)) Then
Set rngCell = rngCell.End(xlDown).Offset(1, 0)
Else
Set rngCell = rngCell.Offset(2, 0)
End If
Else
Set rngCell = rngCell.Offset(1, 0)
End If

Set objFile = mobjFSO.OpenTextFile(FolderPath & Companion &
"_New_UPCs.txt", ForReading)

intLine = 0
Do Until objFile.AtEndOfStream
strText = objFile.ReadLine
intLine = intLine + 1
If intLine 1 Then
rngCell.Value = strText
rngCell.TextToColumns Destination:=rngCell,
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote,
ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False,
Other:=True, OtherChar:="|"
Set rngCell = rngCell.Offset(1, 0)
End If
Loop
objFile.Close
Set rngCell = Nothing
Set objFile = Nothing
End Sub

Private Sub GetSnapShot(ByVal FolderPath As String)
Dim rngCell As Range
Dim rngSnapShot As Range
Dim rngCompanions As Range
Dim objFile As Scripting.TextStream
Dim strPath As String
Dim strLineNew() As String
Dim strLineNothing() As String
Dim strCompanion As String

Set mobjFSO = New FileSystemObject

strPath = FolderPath & "\"

Set rngCompanions = ThisWorkbook.Names
("Safeway").RefersToRange.Offset(1, 0)
Set rngCompanions = Range(rngCompanions, rngCompanions.End
(xlDown))
Set rngSnapShot = ThisWorkbook.Names
("SnapShot").RefersToRange.Offset(1, 0)
If Not IsEmpty(rngSnapShot) Then
Range(rngSnapShot, rngSnapShot.End(xlDown).Offset(0,
16)).ClearContents
End If

Set rngCell = ThisWorkbook.Names("NewUPC").RefersToRange.Offset( 1,
0)
If Not IsEmpty(rngCell) Then
Range(rngCell, rngCell.End(xlDown).Offset(0,
11)).ClearContents
End If


For Each rngCell In rngCompanions
'Get the Companion Name
strCompanion = Trim(rngCell.Value)

'Read Snapshot from the ,New database
Set objFile = mobjFSO.OpenTextFile(strPath & strCompanion &
"_SnapShot_New.txt", ForReading)
strLineNew = Split(objFile.ReadLine, "|")
objFile.Close

'Read Snapshot from the .Nothing database
Set objFile = mobjFSO.OpenTextFile(strPath & strCompanion &
"_SnapShot_Nothing.txt", ForReading)
strLineNothing = Split(objFile.ReadLine, "|")
objFile.Close

'Fill the Details
With rngSnapShot
.Value = strCompanion
'=============================
'Product Dimension Information
'=============================
'Number of products in .NOTHING
.Offset(0, 1).Value = strLineNothing(1)
'Number of products in ,NEW
.Offset(0, 2).Value = strLineNew(1)
'Difference
.Offset(0, 3).FormulaR1C1 = "=ABS(RC[-2]-RC[-1])"
'Number of New UPCs
.Offset(0, 4).Value = strLineNew(2)
If Val(strLineNew(2)) 0 Then
Call GetNewUPC(strPath, strCompanion)
End If

'=============================
'Geography Dimension Information
'=============================
'Number of geographies in .NOTHING
.Offset(0, 6).Value = strLineNothing(2)
'Number of geographies in ,NEW
.Offset(0, 7).Value = strLineNew(3)
'Difference
.Offset(0, 8).FormulaR1C1 = "=ABS(RC[-2]-RC[-1])"

'=============================
'Time Dimension Information
'=============================
'Number of time periods in .NOTHING
.Offset(0, 10).Value = strLineNothing(3)
'Number of time periods in ,NEW
.Offset(0, 11).Value = strLineNew(4)
'Difference
.Offset(0, 12).FormulaR1C1 = "=ABS(RC[-2]-RC[-1])"

'=============================
'Measures Dimension Information
'=============================
'Number of measures in .NOTHING
.Offset(0, 14).Value = strLineNothing(4)
'Number of measures in ,NEW
.Offset(0, 15).Value = strLineNew(5)
'Difference
.Offset(0, 16).FormulaR1C1 = "=ABS(RC[-2]-RC[-1])"
End With
Set rngSnapShot = rngSnapShot.Offset(1, 0)
Next rngCell

Set rngCell = Nothing
Set rngCompanions = Nothing
Set rngSnapShot = Nothing
Set objFile = Nothing
Set mobjFSO = Nothing
End Sub

Try this simple change


From

Set rngSnapShot = rngSnapShot.Offset(1, 0)


to

if rngSnapShot.row <= 5000 then
Set rngSnapShot = rngSnapShot.Offset(1, 0)
else
Set NewSht = sheets.add(after:=sheets(sheets.count))
Set rngSnapShot = Newsht.Range("A1")
end if


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=165382

Microsoft Office Help