PDA

View Full Version : Count the Rows



iwelcomesu
05-20-2011, 12:09 AM
Hi All,
I am using below code to generate Text files to excel files and make one consolidated sheet. I need your help to update below code with few new requirements.

Sub Button1_Click()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rngArea As Range
Dim lrowSpace As Long
Dim lSht As Long
Dim lngCalc As Long
Dim lngRow As Long
Dim lngCol As Long
Dim X()
Dim bProcessFolder As Boolean
Dim bNewSheet As Boolean

Dim StrPrefix
Dim strFileName As String
Dim strFolderName As String

'variant declaration needed for the Shell object to use a default directory
Dim strDefaultFolder As Variant


bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
bNewSheet = (MsgBox("Extract all data to a single sheet (TRUE)," & vbNewLine & "or a target file sheet for each source sheet(FALSE)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
If Not bProcessFolder Then
If Not bNewSheet Then
MsgBox "There isn't much point creating a exact replica of your source file :)"
Exit Sub
End If
End If

'set default directory here if needed
strDefaultFolder = "C:\nonincome"

'If the user is collating all the sheets to a single target sheet then the row spacing
'to distinguish between different sheets can be set here
lrowSpace = 1

If bProcessFolder Then
strFolderName = BrowseForFolder(strDefaultFolder)
'Look for xls, xlsx, xlsm files
strFileName = Dir(strFolderName & "\*.xls*")
Else
strFileName = Application _
.GetOpenFilename("Select file to process (*.xls), *.xls")
End If

Set Wb1 = Workbooks.Add(1)
Set ws1 = Wb1.Sheets(1)
If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")

'Turn off screenupdating, events, alerts and set calculation to manual
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
End With

'set path outside the loop
StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)

Do While Len(strFileName) > 0
'Provide progress status to user
Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
'Open each workbook in the folder of interest
Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
If Not bNewSheet Then
'add summary details to first sheet
ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
End If
For Each ws2 In Wb2.Sheets
If bNewSheet Then
'All data to a single sheet
'Skip importing target sheet data if the source sheet is blank
Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)

If Not rng2 Is Nothing Then
Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
'Find the first blank row on the target sheet
If Not rng1 Is Nothing Then
Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
'Ensure that the row area in the target sheet won't be exceeded
If rng3.Rows.Count + rng1.Row < Rows.Count Then
'Copy the data from the used range of each source sheet to the first blank row
'of the target sheet, using the starting column address from the source sheet being copied
ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
Else
MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
"sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
Wb2.Close False
Exit Do
End If
'colour the first of any spacer rows
If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
Else
'target sheet is empty so copy to first row
ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
End If
End If
Else
'new target sheet for each source sheet
ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
'Remove any links in our target sheet
With Wb1.Sheets(Wb1.Sheets.Count).Cells
.Copy
.PasteSpecial xlPasteValues
End With
On Error Resume Next
Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
'sheet name already exists in target workbook
If Err.Number <> 0 Then
'Add a number to the sheet name till a unique name is derived
Do
lSht = lSht + 1
Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
Loop While Not ws3 Is Nothing
lSht = 0
End If
On Error GoTo 0
End If
Next ws2
'Close the opened workbook
Wb2.Close False
'Check whether to force a DO loop exit if processing a single file
If bProcessFolder = False Then Exit Do
strFileName = Dir
Loop

'Remove any links if the user has used a target sheet
If bNewSheet Then
With ws1.UsedRange
.Copy
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).Activate
End With
Else
'Format the summary sheet if the user has created separate target sheets
ws1.Activate
ws1.Range("A1:B1").Font.Bold = True
ws1.Columns.AutoFit
End If

With Application
.CutCopyMode = False
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
.Calculation = lngCalc
.StatusBar = vbNullString
End With

End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'From Ken Puls as used in his vbaexpress.com article
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284

Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename (file://\\servername\sharename). All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Sub Button2_Click()
Dim FileName As String, Filespec As String, FileFolder As String
Dim wb As Workbook, xlsFile As String, txtFile As String

FileFolder = "C:\nonincome\"
Filespec = FileFolder & "*.txt"

FileName = Dir(Filespec)
If FileName = "" Then Exit Sub

' Loop until no more matching files are found
Do While FileName <> ""
xlsFile = FileFolder & GetBaseName(FileName) & ".xls"
txtFile = FileFolder & FileName
If Not FileExists(xlsFile) Then
'Start the import here...
ImportTxt txtFile
'Save the imported file as xlsFile and close it.
ActiveWorkbook.SaveAs xlsFile, xlWorkbookNormal
ActiveWorkbook.Close False
'End the import here...
End If
FileName = Dir()
Loop
End Sub

Function FileExists(sFilename As String) As Boolean
Dim fso As Object, tf As Boolean
Set fso = CreateObject("Scripting.FileSystemObject")
tf = fso.FileExists(sFilename)
Set fso = Nothing
FileExists = tf
End Function

Function GetBaseName(Filespec As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetBaseName = fso.GetBaseName(Filespec)
End Function
Sub ImportTxt(sFile As String)
Workbooks.OpenText FileName:=sFile, Origin:=437, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 2), Array(7, _
2), Array(99, 2), Array(108, 2)), TrailingMinusNumbers:=True
Range("D8").Select

End Sub


Requirements:


Each sheet contains extra unwanted data should be removed (these are fixed/variable lines from rows (1 to 6,60 to 65, 119 to 124) some files does not contains 60 to 65 or 119 to 124 rows, for each file 1 to 6 rows are fixed.
and count the total of number of lines
Place the total count of lines in first page corresponding to each excel file name.

Please find attached Current output file and required output file for your reference
Assumption that each file contains only one worksheet.

Thanks for your help.

Regards,
Hari

iwelcomesu
05-22-2011, 11:26 PM
Hi,

Can any one solve my problem.

Regards,
Hari

macropod
05-23-2011, 12:51 AM
Hi Hari,

You should be able to delete any unwanted rows with code like:
Dim i As Long
With ActiveSheet
.Range("A119:A124").EntireRow.Delete
.Range("A60:A65").EntireRow.Delete
.Range("A1:A6").EntireRow.Delete
i = .UsedRange.Rows.Count
End With
It does not matter if some of the lines to be deleted don't exist. After deleting, you can get the count and do your output processing. You'll have to change the ActiveSheet reference to whatever worksheet you want to apply this to - you've posted far more code than is relevant to working that out and I don't have time to go through it all for you.

iwelcomesu
05-24-2011, 12:32 AM
Hi macropod,

Thanks for your help, this code is applicable for only one active sheet, my workbook contians around 60 to 70 sheets, can you please provide the code for sheets applicable for below code, and one more requirement is count the number of rows in each sheet and place that that count for all the sheets in one master sheet.

Thanks for your help.

Regards,
Hari

Bob Phillips
05-24-2011, 12:41 AM
Just loop the sheets



Dim i As Long
For Each sh In Activeworkbook
With sh
.Range("A119:A124").EntireRow.Delete
.Range("A60:A65").EntireRow.Delete
.Range("A1:A6").EntireRow.Delete
i = .UsedRange.Rows.Count
End With
Next sh

iwelcomesu
05-24-2011, 03:40 AM
Hi xld,

Thanks for your quick responce, while running this code it it showing as "Run time error, Object doesn't support this property or method" stoping at For loop.

Can you look into that.

Thanks for your help.

Regards,
Hari

Bob Phillips
05-24-2011, 03:48 AM
My error, it should have been



Dim i As Long
For Each sh In Activeworkbook.Worksheets
With sh
.Range("A119:A124").EntireRow.Delete
.Range("A60:A65").EntireRow.Delete
.Range("A1:A6").EntireRow.Delete
i = .UsedRange.Rows.Count
End With
Next sh

iwelcomesu
05-24-2011, 05:48 AM
Hi xld,

Thank you very much for your prompt support, code is working fine, there is one more requirement is Count the Total lines in each sheet contains in "column A" and minus with 1 and paste that count in one new sheet along with the sheet name. (Column A - Sheet Name and Column B - Total Count the line in Column A in each sheet minus 1)

Can you help with my final requirement.

Thanks for your help.

Regards,
Hari

Bob Phillips
05-24-2011, 07:00 AM
Try this



Dim aryData As Variant
Dim sh As Worksheet
Dim i As Long

With ActiveWorkbook

ReDim aryData(1 To .Worksheets.Count, 1 To 2)
For Each sh In .Worksheets
With sh
.Range("A119:A124").EntireRow.Delete
.Range("A60:A65").EntireRow.Delete
.Range("A1:A6").EntireRow.Delete
i = i + 1
aryData(i, 1) = sh.Name
aryData(i, 2) = .UsedRange.Rows.Count
End With
Next sh

.Worksheets.Add after:=.Worksheets(.Worksheets.Count)
i = 0
With ActiveSheet

For i = 1 To .Parent.Worksheets.Count - 1

.Cells(i, "A").Value2 = aryData(i, 1)
.Cells(i, "B").Value2 = aryData(i, 2)
Next i
End With
End With

iwelcomesu
05-24-2011, 07:09 AM
Hi xld,

This code is showing wrong output, cloumn A contians 6 rows minus 1 which result 5 count, but the output is showing as 7 and all the data in cloumn A are in text format.

Thanks for your help.

Regards,
Hari