Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Code to produce consistent new Workbook name
I am using the code below from Ron De Bruin to combine data from a number of
sheets. My problem is that the code opens up a new workbook called Sheet1 and then I am adding additional macros to refer back to Sheet1 to complete my task. However if a user runs this macro again the new workbook is called Sheet2 or Sheet3 or Sheet4 etc which then causes errors with my other code as Sheet1 doesn't exist. Is there a way that the code below can be modified (or via some other method) to ensure that the new file opened is a consistent name? Sub Get_Data(FileNameInA As Boolean, PasteAsValues As Boolean, SourceShName As String, _ SourceShIndex As Integer, SourceRng As String, StartCell As String, myReturnedFiles As Variant) Dim SourceRcount As Long Dim SourceRange As Range, destrange As Range Dim mybook As Workbook, BaseWks As Worksheet Dim rnum As Long, CalcMode As Long Dim SourceSh As Variant Dim sh As Worksheet Dim I As Long 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'Add a new workbook with one sheet named "Combine Sheet" Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) BaseWks.Name = "Combine Sheet" 'Set start row for the Data rnum = 1 'Check if we use a named sheet or the index If SourceShName = "" Then SourceSh = SourceShIndex Else SourceSh = SourceShName End If 'Loop through all files in the array(myFiles) For I = LBound(myReturnedFiles) To UBound(myReturnedFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(myReturnedFiles(I)) On Error GoTo 0 If Not mybook Is Nothing Then If LCase(SourceShName) < "all" Then 'Set SourceRange and check if it is a valid range On Error Resume Next If StartCell < "" Then With mybook.Sheets(SourceSh) Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells)) 'Test if the row of the last cell = then the row of the StartCell If RDB_Last(1, .Cells) < .Range(StartCell).Row Then Set SourceRange = Nothing End If End With Else With mybook.Sheets(SourceSh) Set SourceRange = Application.Intersect(.UsedRange, ..Range(SourceRng)) End With End If If Err.Number 0 Then Err.Clear Set SourceRange = Nothing Else 'if SourceRange use all columns then skip this file If SourceRange.Columns.Count = BaseWks.Columns.Count Then Set SourceRange = Nothing End If End If On Error GoTo 0 If Not SourceRange Is Nothing Then 'Check if there enough rows to paste the data SourceRcount = SourceRange.Rows.Count If rnum + SourceRcount = BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet to paste" mybook.Close savechanges:=False BaseWks.Parent.Close savechanges:=False GoTo ExitTheSub End If 'Set the destination cell If FileNameInA = True Then Set destrange = BaseWks.Range("B" & rnum) With SourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = myReturnedFiles(I) End With Else Set destrange = BaseWks.Range("A" & rnum) End If 'Copy/paste the data If PasteAsValues = True Then With SourceRange Set destrange = destrange. _ Resize(.Rows.Count, ..Columns.Count) End With destrange.Value = SourceRange.Value Else SourceRange.Copy destrange End If rnum = rnum + SourceRcount End If 'Close the workbook without saving mybook.Close savechanges:=False Else 'Loop through all sheets in mybook For Each sh In mybook.Worksheets 'Set SourceRange and check if it is a valid range On Error Resume Next If StartCell < "" Then With sh Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells)) If RDB_Last(1, .Cells) < .Range(StartCell).Row Then Set SourceRange = Nothing End If End With Else With sh Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng)) End With End If If Err.Number 0 Then Err.Clear Set SourceRange = Nothing Else 'if SourceRange use almost all columns then skip this file If SourceRange.Columns.Count BaseWks.Columns.Count - 2 Then Set SourceRange = Nothing End If End If On Error GoTo 0 If Not SourceRange Is Nothing Then 'Check if there enough rows to paste the data SourceRcount = SourceRange.Rows.Count If rnum + SourceRcount = BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet to paste" mybook.Close savechanges:=False BaseWks.Parent.Close savechanges:=False GoTo ExitTheSub End If 'Set the destination cell If FileNameInA = True Then Set destrange = BaseWks.Range("C" & rnum) With SourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = myReturnedFiles(I) BaseWks.Cells(rnum, "B"). _ Resize(.Rows.Count).Value = sh.Name End With Else Set destrange = BaseWks.Range("A" & rnum) End If 'Copy/paste the data If PasteAsValues = True Then With SourceRange Set destrange = destrange. _ Resize(.Rows.Count, ..Columns.Count) End With destrange.Value = SourceRange.Value Else SourceRange.Copy destrange End If rnum = rnum + SourceRcount End If Next sh 'Close the workbook without saving mybook.Close savechanges:=False End If End If 'Open the next workbook Next I 'Set the column width in the new workbook BaseWks.Columns.AutoFit ExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Code to produce consistent new Workbook name
You should use "BaseWks" to refer to the new worksheet and "BaseWks.parent"
to refer to the new workbook. Looking at the code it is calling the new worksheet "Combine Sheet" (not sheet1). the new workbook is called Sheet1, Sheet2, Sheet3. I would make this change from: Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) BaseWks.Name = "Combine Sheet" To: Set BaseWksBk = Workbooks.Add(xlWBATWorksheet) Set BaseWks = BaseWksBk.Sheets(1) BaseWks.Name = "Combine Sheet" Then refer to the new workbook as BaseWksBk "Monk" wrote: I am using the code below from Ron De Bruin to combine data from a number of sheets. My problem is that the code opens up a new workbook called Sheet1 and then I am adding additional macros to refer back to Sheet1 to complete my task. However if a user runs this macro again the new workbook is called Sheet2 or Sheet3 or Sheet4 etc which then causes errors with my other code as Sheet1 doesn't exist. Is there a way that the code below can be modified (or via some other method) to ensure that the new file opened is a consistent name? Sub Get_Data(FileNameInA As Boolean, PasteAsValues As Boolean, SourceShName As String, _ SourceShIndex As Integer, SourceRng As String, StartCell As String, myReturnedFiles As Variant) Dim SourceRcount As Long Dim SourceRange As Range, destrange As Range Dim mybook As Workbook, BaseWks As Worksheet Dim rnum As Long, CalcMode As Long Dim SourceSh As Variant Dim sh As Worksheet Dim I As Long 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'Add a new workbook with one sheet named "Combine Sheet" Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) BaseWks.Name = "Combine Sheet" 'Set start row for the Data rnum = 1 'Check if we use a named sheet or the index If SourceShName = "" Then SourceSh = SourceShIndex Else SourceSh = SourceShName End If 'Loop through all files in the array(myFiles) For I = LBound(myReturnedFiles) To UBound(myReturnedFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(myReturnedFiles(I)) On Error GoTo 0 If Not mybook Is Nothing Then If LCase(SourceShName) < "all" Then 'Set SourceRange and check if it is a valid range On Error Resume Next If StartCell < "" Then With mybook.Sheets(SourceSh) Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells)) 'Test if the row of the last cell = then the row of the StartCell If RDB_Last(1, .Cells) < .Range(StartCell).Row Then Set SourceRange = Nothing End If End With Else With mybook.Sheets(SourceSh) Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng)) End With End If If Err.Number 0 Then Err.Clear Set SourceRange = Nothing Else 'if SourceRange use all columns then skip this file If SourceRange.Columns.Count = BaseWks.Columns.Count Then Set SourceRange = Nothing End If End If On Error GoTo 0 If Not SourceRange Is Nothing Then 'Check if there enough rows to paste the data SourceRcount = SourceRange.Rows.Count If rnum + SourceRcount = BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet to paste" mybook.Close savechanges:=False BaseWks.Parent.Close savechanges:=False GoTo ExitTheSub End If 'Set the destination cell If FileNameInA = True Then Set destrange = BaseWks.Range("B" & rnum) With SourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = myReturnedFiles(I) End With Else Set destrange = BaseWks.Range("A" & rnum) End If 'Copy/paste the data If PasteAsValues = True Then With SourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = SourceRange.Value Else SourceRange.Copy destrange End If rnum = rnum + SourceRcount End If 'Close the workbook without saving mybook.Close savechanges:=False Else 'Loop through all sheets in mybook For Each sh In mybook.Worksheets 'Set SourceRange and check if it is a valid range On Error Resume Next If StartCell < "" Then With sh Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells)) If RDB_Last(1, .Cells) < .Range(StartCell).Row Then Set SourceRange = Nothing End If End With Else With sh Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng)) End With End If If Err.Number 0 Then Err.Clear Set SourceRange = Nothing Else 'if SourceRange use almost all columns then skip this file If SourceRange.Columns.Count BaseWks.Columns.Count - 2 Then Set SourceRange = Nothing End If End If On Error GoTo 0 If Not SourceRange Is Nothing Then 'Check if there enough rows to paste the data SourceRcount = SourceRange.Rows.Count If rnum + SourceRcount = BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet to paste" mybook.Close savechanges:=False BaseWks.Parent.Close savechanges:=False GoTo ExitTheSub End If 'Set the destination cell If FileNameInA = True Then Set destrange = BaseWks.Range("C" & rnum) With SourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = myReturnedFiles(I) BaseWks.Cells(rnum, "B"). _ Resize(.Rows.Count).Value = sh.Name End With Else Set destrange = BaseWks.Range("A" & rnum) End If 'Copy/paste the data If PasteAsValues = True Then With SourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = SourceRange.Value Else SourceRange.Copy destrange End If rnum = rnum + SourceRcount End If Next sh 'Close the workbook without saving mybook.Close savechanges:=False End If End If 'Open the next workbook Next I 'Set the column width in the new workbook BaseWks.Columns.AutoFit ExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Code to produce consistent new Workbook name
Or use BaseWks.parent to point to the workbook
"Joel" wrote: You should use "BaseWks" to refer to the new worksheet and "BaseWks.parent" to refer to the new workbook. Looking at the code it is calling the new worksheet "Combine Sheet" (not sheet1). the new workbook is called Sheet1, Sheet2, Sheet3. I would make this change from: Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) BaseWks.Name = "Combine Sheet" To: Set BaseWksBk = Workbooks.Add(xlWBATWorksheet) Set BaseWks = BaseWksBk.Sheets(1) BaseWks.Name = "Combine Sheet" Then refer to the new workbook as BaseWksBk "Monk" wrote: I am using the code below from Ron De Bruin to combine data from a number of sheets. My problem is that the code opens up a new workbook called Sheet1 and then I am adding additional macros to refer back to Sheet1 to complete my task. However if a user runs this macro again the new workbook is called Sheet2 or Sheet3 or Sheet4 etc which then causes errors with my other code as Sheet1 doesn't exist. Is there a way that the code below can be modified (or via some other method) to ensure that the new file opened is a consistent name? Sub Get_Data(FileNameInA As Boolean, PasteAsValues As Boolean, SourceShName As String, _ SourceShIndex As Integer, SourceRng As String, StartCell As String, myReturnedFiles As Variant) Dim SourceRcount As Long Dim SourceRange As Range, destrange As Range Dim mybook As Workbook, BaseWks As Worksheet Dim rnum As Long, CalcMode As Long Dim SourceSh As Variant Dim sh As Worksheet Dim I As Long 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'Add a new workbook with one sheet named "Combine Sheet" Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) BaseWks.Name = "Combine Sheet" 'Set start row for the Data rnum = 1 'Check if we use a named sheet or the index If SourceShName = "" Then SourceSh = SourceShIndex Else SourceSh = SourceShName End If 'Loop through all files in the array(myFiles) For I = LBound(myReturnedFiles) To UBound(myReturnedFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(myReturnedFiles(I)) On Error GoTo 0 If Not mybook Is Nothing Then If LCase(SourceShName) < "all" Then 'Set SourceRange and check if it is a valid range On Error Resume Next If StartCell < "" Then With mybook.Sheets(SourceSh) Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells)) 'Test if the row of the last cell = then the row of the StartCell If RDB_Last(1, .Cells) < .Range(StartCell).Row Then Set SourceRange = Nothing End If End With Else With mybook.Sheets(SourceSh) Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng)) End With End If If Err.Number 0 Then Err.Clear Set SourceRange = Nothing Else 'if SourceRange use all columns then skip this file If SourceRange.Columns.Count = BaseWks.Columns.Count Then Set SourceRange = Nothing End If End If On Error GoTo 0 If Not SourceRange Is Nothing Then 'Check if there enough rows to paste the data SourceRcount = SourceRange.Rows.Count If rnum + SourceRcount = BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet to paste" mybook.Close savechanges:=False BaseWks.Parent.Close savechanges:=False GoTo ExitTheSub End If 'Set the destination cell If FileNameInA = True Then Set destrange = BaseWks.Range("B" & rnum) With SourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = myReturnedFiles(I) End With Else Set destrange = BaseWks.Range("A" & rnum) End If 'Copy/paste the data If PasteAsValues = True Then With SourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = SourceRange.Value Else SourceRange.Copy destrange End If rnum = rnum + SourceRcount End If 'Close the workbook without saving mybook.Close savechanges:=False Else 'Loop through all sheets in mybook For Each sh In mybook.Worksheets 'Set SourceRange and check if it is a valid range On Error Resume Next If StartCell < "" Then With sh Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells)) If RDB_Last(1, .Cells) < .Range(StartCell).Row Then Set SourceRange = Nothing End If End With Else With sh Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng)) End With End If If Err.Number 0 Then Err.Clear Set SourceRange = Nothing Else 'if SourceRange use almost all columns then skip this file If SourceRange.Columns.Count BaseWks.Columns.Count - 2 Then Set SourceRange = Nothing End If End If On Error GoTo 0 If Not SourceRange Is Nothing Then 'Check if there enough rows to paste the data SourceRcount = SourceRange.Rows.Count If rnum + SourceRcount = BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet to paste" mybook.Close savechanges:=False BaseWks.Parent.Close savechanges:=False GoTo ExitTheSub End If 'Set the destination cell If FileNameInA = True Then Set destrange = BaseWks.Range("C" & rnum) With SourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = myReturnedFiles(I) BaseWks.Cells(rnum, "B"). _ Resize(.Rows.Count).Value = sh.Name End With Else Set destrange = BaseWks.Range("A" & rnum) End If 'Copy/paste the data If PasteAsValues = True Then With SourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = SourceRange.Value Else SourceRange.Copy destrange End If rnum = rnum + SourceRcount End If Next sh 'Close the workbook without saving mybook.Close savechanges:=False End If End If 'Open the next workbook Next I 'Set the column width in the new workbook BaseWks.Columns.AutoFit ExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Code to produce consistent new Workbook name
Thanks Joel
I am getting Compile Errors: Variable Not Defined on the new code: Do I need to make amendments in the group below as well? Dim SourceRcount As Long Dim SourceRange As Range, destrange As Range Dim mybook As Workbook, BaseWks As Worksheet Dim rnum As Long, CalcMode As Long Dim SourceSh As Variant Dim sh As Worksheet Dim I As Long "Joel" wrote: You should use "BaseWks" to refer to the new worksheet and "BaseWks.parent" to refer to the new workbook. Looking at the code it is calling the new worksheet "Combine Sheet" (not sheet1). the new workbook is called Sheet1, Sheet2, Sheet3. I would make this change from: Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) BaseWks.Name = "Combine Sheet" To: Set BaseWksBk = Workbooks.Add(xlWBATWorksheet) Set BaseWks = BaseWksBk.Sheets(1) BaseWks.Name = "Combine Sheet" Then refer to the new workbook as BaseWksBk "Monk" wrote: I am using the code below from Ron De Bruin to combine data from a number of sheets. My problem is that the code opens up a new workbook called Sheet1 and then I am adding additional macros to refer back to Sheet1 to complete my task. However if a user runs this macro again the new workbook is called Sheet2 or Sheet3 or Sheet4 etc which then causes errors with my other code as Sheet1 doesn't exist. Is there a way that the code below can be modified (or via some other method) to ensure that the new file opened is a consistent name? Sub Get_Data(FileNameInA As Boolean, PasteAsValues As Boolean, SourceShName As String, _ SourceShIndex As Integer, SourceRng As String, StartCell As String, myReturnedFiles As Variant) Dim SourceRcount As Long Dim SourceRange As Range, destrange As Range Dim mybook As Workbook, BaseWks As Worksheet Dim rnum As Long, CalcMode As Long Dim SourceSh As Variant Dim sh As Worksheet Dim I As Long 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'Add a new workbook with one sheet named "Combine Sheet" Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) BaseWks.Name = "Combine Sheet" 'Set start row for the Data rnum = 1 'Check if we use a named sheet or the index If SourceShName = "" Then SourceSh = SourceShIndex Else SourceSh = SourceShName End If 'Loop through all files in the array(myFiles) For I = LBound(myReturnedFiles) To UBound(myReturnedFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(myReturnedFiles(I)) On Error GoTo 0 If Not mybook Is Nothing Then If LCase(SourceShName) < "all" Then 'Set SourceRange and check if it is a valid range On Error Resume Next If StartCell < "" Then With mybook.Sheets(SourceSh) Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells)) 'Test if the row of the last cell = then the row of the StartCell If RDB_Last(1, .Cells) < .Range(StartCell).Row Then Set SourceRange = Nothing End If End With Else With mybook.Sheets(SourceSh) Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng)) End With End If If Err.Number 0 Then Err.Clear Set SourceRange = Nothing Else 'if SourceRange use all columns then skip this file If SourceRange.Columns.Count = BaseWks.Columns.Count Then Set SourceRange = Nothing End If End If On Error GoTo 0 If Not SourceRange Is Nothing Then 'Check if there enough rows to paste the data SourceRcount = SourceRange.Rows.Count If rnum + SourceRcount = BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet to paste" mybook.Close savechanges:=False BaseWks.Parent.Close savechanges:=False GoTo ExitTheSub End If 'Set the destination cell If FileNameInA = True Then Set destrange = BaseWks.Range("B" & rnum) With SourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = myReturnedFiles(I) End With Else Set destrange = BaseWks.Range("A" & rnum) End If 'Copy/paste the data If PasteAsValues = True Then With SourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = SourceRange.Value Else SourceRange.Copy destrange End If rnum = rnum + SourceRcount End If 'Close the workbook without saving mybook.Close savechanges:=False Else 'Loop through all sheets in mybook For Each sh In mybook.Worksheets 'Set SourceRange and check if it is a valid range On Error Resume Next If StartCell < "" Then With sh Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells)) If RDB_Last(1, .Cells) < .Range(StartCell).Row Then Set SourceRange = Nothing End If End With Else With sh Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng)) End With End If If Err.Number 0 Then Err.Clear Set SourceRange = Nothing Else 'if SourceRange use almost all columns then skip this file If SourceRange.Columns.Count BaseWks.Columns.Count - 2 Then Set SourceRange = Nothing End If End If On Error GoTo 0 If Not SourceRange Is Nothing Then 'Check if there enough rows to paste the data SourceRcount = SourceRange.Rows.Count If rnum + SourceRcount = BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet to paste" mybook.Close savechanges:=False BaseWks.Parent.Close savechanges:=False GoTo ExitTheSub End If 'Set the destination cell If FileNameInA = True Then Set destrange = BaseWks.Range("C" & rnum) With SourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = myReturnedFiles(I) BaseWks.Cells(rnum, "B"). _ Resize(.Rows.Count).Value = sh.Name End With Else Set destrange = BaseWks.Range("A" & rnum) End If 'Copy/paste the data If PasteAsValues = True Then With SourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = SourceRange.Value Else SourceRange.Copy destrange End If rnum = rnum + SourceRcount End If Next sh 'Close the workbook without saving mybook.Close savechanges:=False End If End If 'Open the next workbook Next I 'Set the column width in the new workbook BaseWks.Columns.AutoFit ExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Code to produce consistent new Workbook name
I forgot in your previous posting you had the datatement
Option Explicit this statement requires you to define all variables. Dim SourceRcount As Long Dim SourceRange As Range, destrange As Range Dim mybook As Workbook, BaseWks As Worksheet Dim rnum As Long, CalcMode As Long Dim SourceSh As Variant Dim sh As Worksheet Dim I As Long 'New ------------------------------------------------------------------ Dim BaseWksBk as Workbook "Monk" wrote: Thanks Joel I am getting Compile Errors: Variable Not Defined on the new code: Do I need to make amendments in the group below as well? Dim SourceRcount As Long Dim SourceRange As Range, destrange As Range Dim mybook As Workbook, BaseWks As Worksheet Dim rnum As Long, CalcMode As Long Dim SourceSh As Variant Dim sh As Worksheet Dim I As Long "Joel" wrote: You should use "BaseWks" to refer to the new worksheet and "BaseWks.parent" to refer to the new workbook. Looking at the code it is calling the new worksheet "Combine Sheet" (not sheet1). the new workbook is called Sheet1, Sheet2, Sheet3. I would make this change from: Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) BaseWks.Name = "Combine Sheet" To: Set BaseWksBk = Workbooks.Add(xlWBATWorksheet) Set BaseWks = BaseWksBk.Sheets(1) BaseWks.Name = "Combine Sheet" Then refer to the new workbook as BaseWksBk "Monk" wrote: I am using the code below from Ron De Bruin to combine data from a number of sheets. My problem is that the code opens up a new workbook called Sheet1 and then I am adding additional macros to refer back to Sheet1 to complete my task. However if a user runs this macro again the new workbook is called Sheet2 or Sheet3 or Sheet4 etc which then causes errors with my other code as Sheet1 doesn't exist. Is there a way that the code below can be modified (or via some other method) to ensure that the new file opened is a consistent name? Sub Get_Data(FileNameInA As Boolean, PasteAsValues As Boolean, SourceShName As String, _ SourceShIndex As Integer, SourceRng As String, StartCell As String, myReturnedFiles As Variant) Dim SourceRcount As Long Dim SourceRange As Range, destrange As Range Dim mybook As Workbook, BaseWks As Worksheet Dim rnum As Long, CalcMode As Long Dim SourceSh As Variant Dim sh As Worksheet Dim I As Long 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'Add a new workbook with one sheet named "Combine Sheet" Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) BaseWks.Name = "Combine Sheet" 'Set start row for the Data rnum = 1 'Check if we use a named sheet or the index If SourceShName = "" Then SourceSh = SourceShIndex Else SourceSh = SourceShName End If 'Loop through all files in the array(myFiles) For I = LBound(myReturnedFiles) To UBound(myReturnedFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(myReturnedFiles(I)) On Error GoTo 0 If Not mybook Is Nothing Then If LCase(SourceShName) < "all" Then 'Set SourceRange and check if it is a valid range On Error Resume Next If StartCell < "" Then With mybook.Sheets(SourceSh) Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells)) 'Test if the row of the last cell = then the row of the StartCell If RDB_Last(1, .Cells) < .Range(StartCell).Row Then Set SourceRange = Nothing End If End With Else With mybook.Sheets(SourceSh) Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng)) End With End If If Err.Number 0 Then Err.Clear Set SourceRange = Nothing Else 'if SourceRange use all columns then skip this file If SourceRange.Columns.Count = BaseWks.Columns.Count Then Set SourceRange = Nothing End If End If On Error GoTo 0 If Not SourceRange Is Nothing Then 'Check if there enough rows to paste the data SourceRcount = SourceRange.Rows.Count If rnum + SourceRcount = BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet to paste" mybook.Close savechanges:=False BaseWks.Parent.Close savechanges:=False GoTo ExitTheSub End If 'Set the destination cell If FileNameInA = True Then Set destrange = BaseWks.Range("B" & rnum) With SourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = myReturnedFiles(I) End With Else Set destrange = BaseWks.Range("A" & rnum) End If 'Copy/paste the data If PasteAsValues = True Then With SourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = SourceRange.Value Else SourceRange.Copy destrange End If rnum = rnum + SourceRcount End If 'Close the workbook without saving mybook.Close savechanges:=False Else 'Loop through all sheets in mybook For Each sh In mybook.Worksheets 'Set SourceRange and check if it is a valid range On Error Resume Next If StartCell < "" Then With sh Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells)) If RDB_Last(1, .Cells) < .Range(StartCell).Row Then Set SourceRange = Nothing End If End With Else With sh Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng)) End With End If If Err.Number 0 Then Err.Clear Set SourceRange = Nothing Else 'if SourceRange use almost all columns then skip this file If SourceRange.Columns.Count BaseWks.Columns.Count - 2 Then Set SourceRange = Nothing End If End If On Error GoTo 0 If Not SourceRange Is Nothing Then 'Check if there enough rows to paste the data SourceRcount = SourceRange.Rows.Count If rnum + SourceRcount = BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet to paste" mybook.Close savechanges:=False BaseWks.Parent.Close savechanges:=False GoTo ExitTheSub End If 'Set the destination cell If FileNameInA = True Then Set destrange = BaseWks.Range("C" & rnum) With SourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = myReturnedFiles(I) BaseWks.Cells(rnum, "B"). _ Resize(.Rows.Count).Value = sh.Name End With Else Set destrange = BaseWks.Range("A" & rnum) End If 'Copy/paste the data If PasteAsValues = True Then With SourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = SourceRange.Value Else SourceRange.Copy destrange End If rnum = rnum + SourceRcount End If Next sh 'Close the workbook without saving mybook.Close savechanges:=False End If End If 'Open the next workbook Next I 'Set the column width in the new workbook BaseWks.Columns.AutoFit ExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Produce a workbook for each employees data in a worksheet | Excel Programming | |||
Dates not consistent | Excel Discussion (Misc queries) | |||
Looping thru multiple files to produce a consolidated summary by Code | Excel Programming | |||
produce a formulate to produce assigned seats for dinner | Excel Worksheet Functions | |||
Code to produce color font in data validation selections | Excel Programming |