Help Fixing a Macro

M

mg_sv_r

Hi,

I'm hoping someone could help me fix a Macro that is giving us problems.

The Macro is probably badly written in parts (well the parts I have added
anyway) because my VBA knowledge is poor at best.

Basically the Macro imports a large csv file, converts the imported data to
columns, takes out unique rows and then does some formula's on an exisiting
worksheet to give us some figures before deleting the sheets created by the
csv file import.

This has always worked fine because the import has always created 2
worksheets, never any more, never any less. Now we have a problem where
sometimes we are getting more or less than 2 worksheets and the Macro falls
over when this happens.

Could someone please help in changing this so it will work regardless of the
number of worksheets created by the file import?

THe Macro is shown below...


--------
Sub FileImport()

'Dimension Variables

Dim ResultStr As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Double

'Filename for Txt file
FileName = "\\Hdqfs001\public_hdq014-fs02\Revenue
Accounts\REVERA\Systems_analysis\JD_month_end_reports\Trans volumes per card
type.txt"

'Get Next Available File Handle Number
FileNum = FreeFile()

'Open Text File For Input
Open FileName For Input As #FileNum

'Turn Screen Updating Off
Application.ScreenUpdating = False

'Create A New Worksheet
ActiveWorkbook.Sheets.Add

'Set The Counter to 1
Counter = 1

'Loop Until the End Of File Is Reached
Do While Seek(FileNum) <= LOF(FileNum)

'Display Importing Row Number On Status Bar
Application.StatusBar = "Importing Row " & _
Counter & " of text file " & FileName

'Store One Line Of Text From File To Variable
Line Input #FileNum, ResultStr

'Store Variable Data Into Active Cell
If Left(ResultStr, 1) = "=" Then
ActiveCell.Value = "'" & ResultStr
Else
ActiveCell.Value = ResultStr
End If

'If on the last row of worksheet create a new worksheet
If ActiveCell.Row = 65536 Then
ActiveWorkbook.Sheets.Add
Else
'If Not The Last Row Then Go One Cell Down
ActiveCell.Offset(1, 0).Select
End If

'Increment the Counter By 1
Counter = Counter + 1

'Start Again At Top Of 'Do While' Statement
Loop

'Close The Open Text File
Close

'Remove Message From Status Bar
Application.StatusBar = False

'Select the first column of the first worksheet created
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select

'Convert the imported text rows to columns
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False,
Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False,
FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Delete the columns we do not need
Range("B1:C1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireColumn.Delete
Range("C1:E1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireColumn.Delete

'Insert a row on sheet2 for headers
Range("A1:D1").Select
Selection.EntireRow.Insert

'Select the first column of the other created worksheet
Range("A1").Select
ActiveSheet.Next.Select

'Convert the text rows to columns
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False,
Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False,
FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True

'delete the rows we do not need
Range("B1:C1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlToLeft
Range("C1:E1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlToLeft
Range("A1:D1").Select
Range(Selection, Selection.End(xlDown)).Select

'filter out the duplicated data from the imported data
Columns("A:D").AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=Columns( _
"F:I"), Unique:=True
Range("A1:E1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
ActiveSheet.Previous.Select
Range("A1").Select
ActiveSheet.Paste
Range("A1:D1").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Range("A1:D26110").AdvancedFilter Action:=xlFilterCopy, CopyToRange:= _
Columns("F:I"), Unique:=True
Range("A1:E1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireColumn.Delete
Range("A1").Select
ActiveSheet.Next.Select
ActiveSheet.Next.Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.SeriesCollection(3).Select
ActiveChart.SeriesCollection(2).Select
ActiveChart.SeriesCollection(1).Select
ActiveChart.Axes(xlValue).MajorGridlines.Select
ActiveWindow.Visible = False
Windows("Transaction Volumes by Card Type Template.xls").Activate


Range("C4").Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
Loop

Selection.EntireColumn.Insert
Application.CutCopyMode = False
ActiveSheet.Previous.Select
Range("A2").Select
Selection.Copy
ActiveSheet.Next.Select
Range("C4").Select

'find the next empty cell in row
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
Loop

ActiveSheet.Paste
Application.CutCopyMode = False

With Selection.Font
.Name = "Verdana"
.FontStyle = "Bold"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2
End With
With Selection.Interior
.ColorIndex = 49
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With

Selection.Copy
ActiveCell.Offset(36, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

ActiveCell.Offset(-31, -1).Select
Selection.Copy
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False

ActiveCell.Offset(-4, 0).Select
ActiveCell.FormulaR1C1 =
"=SUM(COUNTIF(Sheet1!R2C3:R65536C3,R5C2))+(COUNTIF(Sheet2!R2C3:R65536C3,R5C2))"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 =
"=SUM(COUNTIF(Sheet1!R2C3:R65536C3,R6C2))+(COUNTIF(Sheet2!R2C3:R65536C3,R6C2))"


'Replace the formulas with actual values
Range("B5").Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
Loop
ActiveCell.Offset(0, -1).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(1, 0).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

'Delete the Worksheets
ActiveSheet.Previous.Select
ActiveWindow.SelectedSheets.Delete
ActiveSheet.Previous.Select
ActiveWindow.SelectedSheets.Delete

Range("B41").Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
Loop

ActiveCell.Offset(0, -1).Select
Selection.Copy
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste

ActiveCell.Offset(1, -1).Select
Selection.Copy
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste

End Sub


--------

Any help would be very much appreciated.

Regards
John
 
D

DomThePom

Sorry mate - don't have the time to go through this in detail but here are
some pointers:
General
* When referring to a sheet it helps to be specific - define a sheet
variable and use it - using activesheet is too ambiguous
* There is a lot of selecting going on - when you are doing stuff in excel
vba you rarely need to select it - the selection is just a range - it is much
easier to be specific about the range which you want to work on
* Likewise - activecell - what may ar may not be active is sometimes unclear
- be specific about the cell you want to work on
Specific
* As you say, the macro assumes 2 sheets of data
* You need to modify it so you create a loop to determine how many sheets
you have created and then just work on those sheets
* Probably be better to have sheets with raw data in it and then create
sheets (maywe in another book) where you copy the unique items to - that way
you have a complete trail of data)
* create a criteria sheet for your criterias (seem to be hiding them at the
bottom of the worksheet)
Hope this helps
 
J

Joel

Try these changes. It is not fully tested, but it should help. I wasn't
sure which worksheets were being deleted so I didn't put these statement in
the code below.

Sub FileImport()

'Dimension Variables

Dim ResultStr As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Double
Dim MySheets(1) As Worksheet
Dim NumberSheets As Integer

'Filename for Txt file
FileName = "\\Hdqfs001\public_hdq014-fs02\" & _
"Revenue Accounts\REVERA\Systems_analysis\" & _
"JD_month_end_reports\Trans volumes per card type.txt"

'Get Next Available File Handle Number
FileNum = FreeFile()

'Open Text File For Input
Open FileName For Input As #FileNum

'Turn Screen Updating Off
Application.ScreenUpdating = False

'Create A New Worksheet
ActiveWorkbook.Sheets.Add
Set MySheets(0) = ActiveSheet
NumberSheets = 1
'Set The Counter to 1
Counter = 1

'Loop Until the End Of File Is Reached
Do While Seek(FileNum) <= LOF(FileNum)

'Display Importing Row Number On Status Bar
Application.StatusBar = "Importing Row " & _
Counter & " of text file " & FileName

'Store One Line Of Text From File To Variable
Line Input #FileNum, ResultStr

'Store Variable Data Into Active Cell
If Left(ResultStr, 1) = "=" Then
ActiveCell.Value = "'" & ResultStr
Else
ActiveCell.Value = ResultStr
End If

'If on the last row of worksheet create a new worksheet
If ActiveCell.Row = 65536 Then
ActiveWorkbook.Sheets.Add
NumberSheets = NumberSheets + 1
ReDim Preserve MySheets(NumberSheets)
MySheets(NumberSheets - 1) = ActiveSheet
Else
'If Not The Last Row Then Go One Cell Down
ActiveCell.Offset(1, 0).Select
End If

'Increment the Counter By 1
Counter = Counter + 1

'Start Again At Top Of 'Do While' Statement
Loop

'Close The Open Text File
Close

'Remove Message From Status Bar
Application.StatusBar = False

With MySheets(0)
'Select the first column of the first worksheet created
.Range("A1").Select
.Range(Selection, Selection.End(xlDown)).Select

'Convert the imported text rows to columns
Selection.TextToColumns _
Destination:=.Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=False, _
FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
'Delete the columns we do not need
.Range("B1:C1").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.EntireColumn.Delete
.Range("C1:E1").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.EntireColumn.Delete
End With
If NumberSheets = 2 Then
With MySheets(0)

'Insert a row on sheet2 for headers
.Range("A1:D1").Select
Selection.EntireRow.Insert

'Select the first column of the other created worksheet
.Range("A1").Select

'Convert the text rows to columns
.Range("A1").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns _
Destination:=.Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=False, _
FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True

'delete the rows we do not need
.Range("B1:C1").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlToLeft
.Range("C1:E1").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlToLeft
.Range("A1:D1").Select
.Range(Selection, Selection.End(xlDown)).Select

'filter out the duplicated data from the imported data
.Columns("A:D").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Columns("F:I"), _
Unique:=True
.Range("A1:E1").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlToLeft
.Range("A1").Select
.Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
End With
With MySheets(0)

.Range("A1").Select
.ActiveSheet.Paste
.Range("A1:D1").Select
.Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
.Range("A1:D26110").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Columns("F:I"), _
Unique:=True
.Range("A1:E1").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.EntireColumn.Delete
.Range("A1").Select
End With
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.SeriesCollection(3).Select
ActiveChart.SeriesCollection(2).Select
ActiveChart.SeriesCollection(1).Select
ActiveChart.Axes(xlValue).MajorGridlines.Select
ActiveWindow.Visible = False
Windows("Transaction Volumes by Card Type Template.xls").Activate


Range("C4").Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
Loop

Selection.EntireColumn.Insert
Application.CutCopyMode = False
ActiveSheet.Previous.Select
Range("A2").Select
Selection.Copy
ActiveSheet.Next.Select
Range("C4").Select

'find the next empty cell in row
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
Loop

ActiveSheet.Paste
Application.CutCopyMode = False

With Selection.Font
.Name = "Verdana"
.FontStyle = "Bold"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 2
End With
With Selection.Interior
.ColorIndex = 49
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With

Selection.Copy
ActiveCell.Offset(36, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False

ActiveCell.Offset(-31, -1).Select
Selection.Copy
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False

ActiveCell.Offset(-4, 0).Select
ActiveCell.FormulaR1C1 = _
"=SUM(COUNTIF(Sheet1!R2C3:R65536C3,R5C2))+" & _
"(COUNTIF(Sheet2!R2C3:R65536C3,R5C2))"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = _
"=SUM(COUNTIF(Sheet1!R2C3:R65536C3,R6C2))+" & _
"(COUNTIF(Sheet2!R2C3:R65536C3,R6C2))"


'Replace the formulas with actual values
Range("B5").Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
Loop
ActiveCell.Offset(0, -1).Select
Selection.Copy
Selection.PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(1, 0).Select
Selection.Copy
Selection.PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False

'Delete the Worksheets
' ActiveSheet.Previous.Select
' ActiveWindow.SelectedSheets.Delete
' ActiveSheet.Previous.Select
' ActiveWindow.SelectedSheets.Delete

Range("B41").Select
Do Until ActiveCell.Value = ""
ActiveCell.Offset(0, 1).Select
Loop

ActiveCell.Offset(0, -1).Select
Selection.Copy
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste

ActiveCell.Offset(1, -1).Select
Selection.Copy
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste

End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Macro to fill to next field with data 4
works in 2007 but not in 2010 0
Help me4 2
Help me5 1
Paste failing after cut 8
Run a procedure in all the sheets of the workbook. 1
On error goto specified Line 6
If Cells.Find returns run-time error '91': Object variableor With block variable not set 1

Top