it's me, again.
I have a code that import a reference sheet on wb_open. Im trying something new to get my code faster but it's creating a problem.
My new code delete (instead of copi-pasting) the existing internal Ref sheet and replace is by the external (refreshed or not) one.
The problem comes from the fact that deleting the internal ref sheet deletes my in-cell reference to that sheet even tho im naming the newly copied sheet the exact same name. Is there a way to get around?
Sub Workbook_open()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim Sheetname As String
Sheetname = "cédule détaillée 2 "
Worksheets(Sheetname).Visible = True
Dim externalwb As Workbook
Set externalwb = Workbooks.Open(fileName:="\\Backup\Opérations\Coaticook\Planification\Cédule détaillées\Cédule détaillées des composantes.xlsx")
Dim curentSheetNumber As Long
currentSheetNumber = ThisWorkbook.Worksheets(Sheetname).Index
ThisWorkbook.Worksheets(Sheetname).Delete
externalwb.Worksheets(Sheetname).Copy After:=ThisWorkbook.Worksheets(currentSheetNumber - 1)
externalwb.Close False
Worksheets(Sheetname).Visible = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Try implementing the next formula copying approach, please:
Sub testCopyFormulas()
Dim sh As Worksheet, rngForm As Range, shN As Worksheet
Set sh = ActiveSheet
Set rngForm = sh.UsedRange.SpecialCells(xlCellTypeFormulas)
Set shN = Worksheets.Add
shN.Range(rngForm.Address).Formula = rngForm.Formula
End Sub
And specifically in your code, try this approach:
'...your code...
Dim externalwb As Workbook, rngForm As Range
Set externalwb = Workbooks.Open(fileName:="\\Backup\Opérations\Coaticook\Planification\Cédule détaillées\Cédule détaillées des composantes.xlsx")
Dim curentSheetNumber As Long
Set rngForm = ThisWorkbook.Worksheets(Sheetname).SpecialCells(xlCellTypeFormulas)
currentSheetNumber = ThisWorkbook.Worksheets(Sheetname).Index
ThisWorkbook.Worksheets(Sheetname).Delete
externalwb.Worksheets(Sheetname).Copy After:=ThisWorkbook.Worksheets(currentSheetNumber - 1)
externalwb.Close False
ThisWorkbook.Worksheets(Sheetname).Range(rngForm.Address).Formula = rngForm.Formula
'...Your code...
Related
I'm looking for a way or method to copy (adding new) columns between sheets.
Let me illustrate:
Sheet: template
Sheet: student
Initially I duplicate "Template" and rename it.
But when additional tasks are added to "Template" I want to update "Student" minding that I have already changed the content in range B2:D4. So copy/pasting the whole range is not an option.
What's the best way to go about this?
First checking if row A in the destination sheet has a value, if not copy/paste that column?
A push in the right direction (or some code to get started on) would be very much appreciated.
You can achieve this by looping true columns headers, given they are in the first row and all tabs are named appropriately:
Sub AddTask()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.DisplayStatusBar = True
End With
Dim wb As Workbook: Set wb = ThisWorkbook
With wb
Dim LastTemplateCol As Long: LastTemplateCol = .Worksheets("Template").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To LastTemplateCol
Dim TempTask As String: TempTask = .Worksheets("Template").Cells(1, i).Value
Dim LastStudentCol As Long: LastStudentCol = .Worksheets("Student").Cells(1, Columns.Count).End(xlToLeft).Column
For t = 2 To LastStudentCol
Dim StudTask As String: StudTask = .Worksheets("Student").Cells(1, t).Value
Dim Exists As Boolean: Exists = False
If TempTask = StudTask Then
Exists = True
GoTo taskloop:
Else
GoTo studloop:
End If
studloop:
Next t
If Exists = False Then
.Worksheets("Template").Cells(1, i).Columns.EntireColumn.Copy
.Worksheets("Student").Cells(1, LastStudentCol + 1).PasteSpecial
End If
taskloop:
Next i
End With
Application.CutCopyMode = False
End Sub
I'm simply trying to "Cut" a range of cells from one sheet to another. I've never been able to make the ".Cut" work but the ".Copy" works with an error ("Run-time error '424': Object required"). I don't understand why ".Cut" doesn't work as simple as ".Copy" and what the error is.
Private Sub mti_line62_Click()
Dim infreq As Worksheet
Dim freq As Worksheet
Dim mti_player As Range
Dim line62 As Range
Set infreq = ThisWorkbook.Worksheets("INFREQ")
Set freq = ThisWorkbook.Worksheets("Frequent")
Set mti_player = infreq.Range("D" & Rows.Count).End(xlUp).Offset(1)
Set line62 = freq.Range("D62:Q62")
mti_player.PasteSpecial = freq.Range("D62:Q62").Copy
'mti_player.PasteSpecial = freq.Range("D62:Q62").Cut
'mti_player.PasteSpecial = line62.Copy
'freq.Range("D62:Q62").Clear
Application.CutCopyMode = False
infreq.Activate
End Sub
This Macro was created by my predecessor, and I would like to clean it up to be more efficient.
The Variables are not defined, and I would like to make sure I'm doing this correctly.
The Macro starts with one Workbook open, but opens other Workbooks, pulls the data, and pastes into the first workbook.
Sub DataPaste()
'Turn Off Screen Updates
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'Open Standard Data Reports
Workbooks.Open "O:\Wholesale\Reporting\Market6 Scorecard\Templates\26 Wk Data.csv"
'Copy 26 Wk Data
Set dWkData = Workbooks("26 Wk Data.csv").Worksheets("26 Wk Data")
Set dDataPaste = Workbooks("KROGER M6 SCORECARD TEMPLATE.xlsm").Worksheets("COMBINED")
dTemplateLastRow = dDataPaste.Cells(dDataPaste.Rows.Count, "B").End(xlUp).Offset(1).Row
dCopyLastRow = dWkData.Cells(dWkData.Rows.Count, "A").End(xlUp).Row
dWkData.Range("A18:H" & dCopyLastRow).Copy dDataPaste.Range("B" & dTemplateLastRow)
dWkData.Range("I18:R" & dCopyLastRow).Copy dDataPaste.Range("L" & dTemplateLastRow)
'Add Dates
dTemplateLastRowb = dDataPaste.Cells(dDataPaste.Rows.Count, "B").End(xlUp).Row
dTemplateLastRowc = dDataPaste.Cells(dDataPaste.Rows.Count, "B").End(xlUp).Offset(1).Row
Set dFirstRow = Workbooks("KROGER M6 SCORECARD TEMPLATE.xlsm").Worksheets("COMBINED").Range("A" & cTemplateLastRowc)
Set dLastRow = Workbooks("KROGER M6 SCORECARD TEMPLATE.xlsm").Worksheets("COMBINED").Range("A" & dTemplateLastRowb)
Range(dFirstRow, dLastRow).Formula = "=concatenate(""Latest 26 Wks - Ending "",left(right('Weekly Division'!$A$4,24),23))"
'Close Standard Data Reports
Workbooks("26 Wk Data.csv").Close SaveChanges:=False
'Calculate Workbook
Calculate
'Save File as Template File
ActiveWorkbook.Save
'Turn on Screen Updates
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
I'm assuming something like this??
'Copy 26 Wk Data
Dim dWkData as Long
Dim dDataPaste as Long
Set dWkData = Workbooks("26 Wk Data.csv").Worksheets("26 Wk Data")
Set dDataPaste = Workbooks("KROGER M6 SCORECARD TEMPLATE.xlsm").Worksheets("COMBINED")
Dim dTemplateLastRow as Long
Dim dCopyLastRow as Long
dTemplateLastRow = dDataPaste.Cells(dDataPaste.Rows.Count, "B").End(xlUp).Offset(1).Row
dCopyLastRow = dWkData.Cells(dWkData.Rows.Count, "A").End(xlUp).Row
dWkData.Range("A18:H" & dCopyLastRow).Copy dDataPaste.Range("B" & dTemplateLastRow)
dWkData.Range("I18:R" & dCopyLastRow).Copy dDataPaste.Range("L" & dTemplateLastRow)
Not really:
Change, please:
Dim dWkData as Long
Dim dDataPaste as Long
with:
Dim dWkData as Worksheet
Dim dDataPaste as Worksheet
You can also declare and use. To make the code easy to be read, shorter, especially when you (may) need the workbooks for other worksheets, also. Here, only an example of using it:
Dim WbD as Workbook, WbK as Workbook
Set WbD = Workbooks("26 Wk Data.csv")
Set WbK = Workbooks("KROGER M6 SCORECARD TEMPLATE.xlsm")
Set dWkData = WbD.Worksheets("26 Wk Data")
Set dDataPaste = WbK.Worksheets("COMBINED")
Here are all of the declarations you need to set up to use the code you supplied:
Dim dWkData As Worksheet, dDataPaste As Worksheet
Dim dTemplateLastRow As Long, dCopyLastRow As Long, dTemplateLastRowb As Long, dTemplateLastRowc As Long
Dim dLastRow As Range, dFirstRow As Range
However, I also notice there appears to be a typo on this line:
Set dFirstRow = Workbooks("KROGER M6 SCORECARD TEMPLATE.xlsm").Worksheets("COMBINED").Range("A" & cTemplateLastRowc)
I think at the end there it should read dTemplateLastRowc not cTemplateLastRowc.
As an extra aside, you will often see authors include a hint of the datatype within the variable names, so you might want to consider renaming your variables/objects to something like this:
dWkData -> wsData
dDataPaste -> wsDataPaste
dTemplateLastRow -> lngTemplateLastRow (or lTemplateLastRow)
dCopyLastRow -> lngCopyLastRow (or l..)
dTemplateLastRowb -> lngTemplateLastRowb (or l..)
dLastRow -> rngLastRow
This makes it much easier to remember what you're using the variable/object for when adding new code/making changes.
Just another point if you're trying to solidify the code - if you're using these:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Then it's also good practice to use an error handler to force the routine to switch these back to their defaults at the end of the routine, just in case something goes wrong (Although later versions of Excel seem to fix some of these on error)
You already have them reverting correctly at the end:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
But if something broke along the way then these last statements wouldn't get executed and, depending on your Excel version, you might be left with frozen screens, no safety alerts and frozen formulae.
For this reason, if I ever use these I always put a goto error statement just after the initial bit:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error GoTo ErrHandler ' tells the runtime if an error occurs to jump to "ErrHandler" line
And then I put that error handler line right above the last bit so it knows where to jump to:
ErrHandler: ' Will jump to here if something goes wrong
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
I have a call procedure to clear contents of tables across multiple worksheets.
This procedure is invoked only from the 2nd sheet of the workbook. When I invoke this, I am getting Error 1004 "Application-defined or Object-defined error".
Below is the parent code base invoking the sub procedure:
Sub ValidateData_BDV1()
On Error Resume Next
Err.Clear
'''''Define Variables'''''''''
Dim mySheet As Worksheet
Dim mySheetName As String
Dim bdvName As Variant
Dim sqlQuery As String
Dim connectStr As String
Dim wsMatch As Worksheet
Dim myWorkbook As Workbook: Set myWorkbook = ThisWorkbook
'''''''''Set Variables''''''''
cancelEvent = False
Set mySheet = ActiveSheet 'Sets mySheet variable as current active sheet
mySheetName = mySheet.Name
driverName = mySheet.Range("B1").Value2 'Get the value of the TDV driver
' MsgBox driver
dataSourceName = mySheet.Range("B3").Value2 'Get the data source name for the published TDV database
' MsgBox dataSourceName
schemaName = mySheet.Range("B5").Value2 'Get the schema name of the published tdv view
bdvName = mySheet.Range("B6").Value2 'Get the name of the published BDV
''''''''''Refresh data across sheets'''''''''''''
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
'''''''''''''''''''''''''''''''''''''''
''''''''''''Call sub procedure'''''''''
Call ClearTableContents
''''''''''''''''''''''''''''''''''''
mySheet.Activate
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
''''''''Show User id and Password box'''''''''
If Len(Uid) < 1 Or Len(Password) < 1 Then
UserForm1.Show
End If
If (cancelEvent = True) Then
Exit Sub
End If
............
............perform some task with error handling
Below is the code base of the called Sub
Sub ClearTableContents()
Dim wrksht As Worksheet
Dim objListObj As ListObjects
Dim tableName As String
Dim ActiveTable As ListObject
Dim rowCount As Integer
Dim colCount As Integer
Dim i As Integer
Dim j As Integer
'''''Iterate through the Bdv1, bdv2 and Match sheets. Set default table sizes for each
sheet'''''''''
For j = 2 To 4
If (j = 2) Or (j = 3) Then
rowCount = 5
colCount = 6
ElseIf (j = 4) Then
rowCount = 5
colCount = 9
End If
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
Set wrksht = ActiveWorkbook.Worksheets(j)
Set objListObj = wrksht.ListObjects 'Get list of tables objects from the current sheet
'''''''Iterate through the tables in the active worksheet''''''''''''''
For i = 1 To objListObj.Count
tableName = objListObj(i).Name
Set ActiveTable = wrksht.ListObjects(tableName)
On Error Resume Next
''''''For each table clear the contents and resize the table to default settings''''''''''''
With wrksht.ListObjects(i)
.DataBodyRange.Rows.Clear
.Range.Rows(rowCount & ":" & .Range.Rows.Count).Delete
.HeaderRowRange.Rows.ClearContents
.HeaderRowRange.Rows.Clear
.Range.Columns(colCount & ":" & .Range.Columns.Count).Delete
.Resize .Range.Resize(rowCount, colCount)
End With
wrksht.Columns("A:Z").AutoFit
Next i
Next j
ThisWorkbook.Worksheets(2).Activate '''set the active sheet to the sheet number 2
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
Exit Sub
'Error Handling
NoTableSelected:
MsgBox "There is no Table currently selected!", vbCritical
End Sub
Please help in resolving the issue.
If I execute as independent macro on click of the button, it works perfectly well.
I am going to post this as an "answer", since I think it may at least help, if not solve, your issue.
Clearing tables (list objects) via VBA code can be a little tricky, and I learned this hard way. I developed and have been using the below function for quite some time and it works like a charm. There are comments to explain the code in the function.
Sub clearTable(whichTable As ListObject)
With whichTable.DataBodyRange
'to trap for the bug where using 'xlCellTypeConstants' against a table with only 1 row and column will select all constants on the worksheet - can't explain more than that its a bug i noticed and so did others online
If .rows.count = 1 And .columns.count = 1 Then
If Not .Cells(1, 1).HasFormula Then .Cells(1, 1).ClearContents
Else
'my tables often have formulas that i don't want erased, but you can remove if needed
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End If
'remove extra rows so table starts clean
Dim rowCount As Long
rowCount = .rows.count
If rowCount > 1 Then .rows("2:" & rowCount).Delete 'because you can't delete the first row of the table. it will always have 1 row
End With
End Sub
Call the procedure like this:
Dim lo as ListObject
For each lo in Worksheets(1).ListObjects
clearTable lo
next
Commented line to make my code work
.Range.Columns(colCount & ":" &
.Range.Columns.Count).Delete
I was writing my code when simply some function are not working properly anymore. I have a project and It has a function to copy a archive from a folder to other folder, 3 hours ago it worked properly, now every archive that I copy get corrupted. Same thing happened with another macro that I made to complete a report with some informations, when I execute simply corrupt the file. I'm desperated and I don't know what to do. I've already reinstalled excel, I've already tried to run an old code that I saved for security, same error.
The codes:
Private Sub arquivo_reports(line_b, new_add, old_add, opcao)
Dim sheet_ As Workbook
Dim report As Worksheet, informations As Worksheet
If (opcao = 1) Then
FileCopy old_add, new_add
End If
Set sheet_ = Workbooks.Open(new_add, False, False)
ActiveWindow.Visible = False
ThisWorkbook.Activate
Application.ScreenUpdating = True
Set report = sheet_.Worksheets("reports")
sheet_.Close SaveChanges:=True
End Sub
Public Sub fill_creport()
Dim line_complain As Integer
Dim path As String
Dim sheet_report As Workbook
Dim report As Worksheet
path = FileOpenDialogBox()
Set sheet_report = Workbooks.Open(path, False, False)
ActiveWindow.Visible = False
ThisWorkbook.Activate
Application.ScreenUpdating = False
Set report = sheet_report.Worksheets("report")
line_complain = 4 + Application.Match(report.Cells(1, 21).Value, Range("A5:A600"), 0)
End Sub