Modify The Code For Importing Text File into an Excel File

[vicky]

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

 

[joel]

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 i

 

[vicky]

thank i ll give a try .....hey can you give me a vba code to delete
all the sheets in a current workbook whose sheet name are not
coloured .......

 

[joel]

Application.DisplayAlerts = False
For ShtCount = Sheets.Count To 1 Step -1
With Sheets(ShtCount)
If .Tab.ColorIndex = xlNone Then
.Delete
End If
End With

Next ShtCount
Application.DisplayAlerts = Tru

 

[vicky]

Thanks a lot .... if you could help me with importing text file into
excel sheet then ta wuld be really helpful. thanks once again.sorry if
i am asking more

 

[joel]

If you can attached the workbook and the file you are importing I ca
take a look. Use TheCagecode website

http://tinyurl.com/yfx9ytj


Reply to your message and the add the files using the button "Manag
Attachments"