| Home |
| Search |
| Today's Posts |
|
|
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Help Fixing a Macro
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_repo rts\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 |
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Help Fixing a Macro
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 "mg_sv_r" wrote: 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_repo rts\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 |
|
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Help Fixing a Macro
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 "mg_sv_r" wrote: 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_repo rts\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 |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| Fixing the date format in a macro or VBA | Excel Worksheet Functions | |||
| Fixing macro to choose a blank row | Excel Programming | |||
| Fixing SSN's with a macro | Excel Programming | |||
| Help Fixing Coloring Macro | Excel Programming | |||
| fixing macro to highlight a row if a checkbox is checked | Excel Programming | |||
Hybrid Mode
