Data validations lost when copying worksheet using VBA macro - vba

Problem: I am having a problem with data validations not copying to the copied worksheet when a worksheet is copied using a macro. Is there any way to do this using my current code?
Yes, I am also aware that there is a similar question (Here: Data validation lost when I copy a worksheet to another workbook) but it isn't quite the same issue and does not yet at this time have an answer. Any help to get these data validations to copy along with the data would be much appreciated and will save hours of needless repetitive work.
Edit: This code is in the "ThisWorkbook" section of my workbook.
My code is as follows:
Dim wb As Workbook
Dim wsTemp As Worksheet
Dim sName As String
Dim bValidName As Boolean
Dim i As Long
bValidName = False
Do While bValidName = False
sName = InputBox("Please name this new worksheet:", "New Sheet Name", Sh.Name)
If Len(sName) > 0 Then
For i = 1 To 7
sName = Replace(sName, Mid(":\/?*[]", i, 1), " ")
Next i
sName = Trim(Left(WorksheetFunction.Trim(sName), 31))
If Not Evaluate("ISREF('" & sName & "'!A1)") Then bValidName = True
End If
Loop
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set wsTemp = wb.Sheets("TEMPLATE")
wsTemp.Visible = xlSheetVisible
wsTemp.Copy After:=wb.Sheets(wb.Sheets.Count)
ActiveSheet.Name = sName
Sh.Delete
wsTemp.Visible = xlSheetHidden 'Or xlSheetVeryHidden
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
' Call Sort_Active_book
' Call Rebuild_TOC

You should be able to copy a worksheet and retain DV. This example:
Activates Sheet1
creates a simple DV on Sheeet1
copies Sheet1 to the end of the workbook
Sub Macro2()
Sheets("Sheet1").Select
Range("D1").Select
ActiveCell.FormulaR1C1 = "alpha"
Range("D2").Select
ActiveCell.FormulaR1C1 = "beta"
Range("D3").Select
ActiveCell.FormulaR1C1 = "gamma"
Range("B1").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$D$1:$D$3"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Sheets("Sheet1").Select
Sheets("Sheet1").Copy After:=Sheets(3)
End Sub
This is recorded code run on a new, empty workbook on a Win 7/Excel 2007 system.
Can you replicate my result ??
If my code works on your system, begin by trying to mimic your VBA code manually with the recorder turned. Then take your recorded code and modify it to include non-recordable parts, (like the InputBox statements).

Related

VBA - Checking Two Different Path Locations

I have an existing VBA Project that I simply need to modify even if does scream to be re-written one day.
The sheet has a hidden sheet called Options that lists a file path in B3 and that path is called \fileserver\Drafting\MBS_JOBS\
The code then assigns a variable this path:
strpathtofile = Sheets("Options").Range("B3").Value
Finally, later on, it puts it all together with this:
strFileToOpen = strpathtofile & ActiveCell.Value & strFilename
What I need to do now is have it check a second path. So I've duplicated some of the code.
I first put the new path in B7 of the OPTIONS page. Then, I created a variable and assigned it:
Public strpathtoProj As String
strpathtoProj = Sheets("Options").Range("B7").Value
So, what I need to do is have this program also check this other path. So wondering if I need some kind of IF, THEN or ELSE statement around this part:
strFileToOpen = strpathtofile & ActiveCell.Value & strFilename
To also make it look at strpathtoProj.
I'm a "work in progress" VBA developer as a SOLO IT guy for a small business and am learning as I go.
Here are the modules that use strpathtofile (and you can see that I've already got some code in there for the strpathtoProj that I now need to use):
Sub RUN_SUMMARY_REPORT()
'assign variable... this is here just in case they haven't ran the "TEST" button
strpathtofile = Sheets("Options").Range("B3").Value
strFilename = Sheets("Options").Range("B4").Value
strThisBook = Sheets("Options").Range("B5").Value
strExtraInformation = Sheets("Options").Range("B6").Value
strpathtoProj = Sheets("Options").Range("B7").Value
'assign variable... this is here just in case they haven't ran the "TEST" button
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Unprotect
'Remove any past data
SHOW_WARNING (False)
' Extended The Range To Remove data that continued below line 44. Brian
1/20/2015
' Range("C2:C200").ClearContents ' Jobs
Range("F4:S13").ClearContents ' Bar
Range("G17:G23").ClearContents ' Web Plate
Range("J17:J19").ClearContents ' Cable
Range("M17:M23").ClearContents ' Rod
Range("P17:P25").ClearContents ' Angle
'Remove any past data
'initialize ExtraInformation
Sheets(strExtraInformation).Range("A1:K1000").ClearContents
Sheets(strExtraInformation).Select
Range("A1").Select
'initialize ExtraInformation
SHOW_SHEETS (True)
INITIALIZE_PUBLIC_VARS
IMPORT_ALL_INFORMATION
PRINT_WEB_DATA
PRINT_BAR_DATA
PRINT_BRAC_DATA
PRINT_ROD_DATA
PRINT_ANGLE_DATA
SHOW_SHEETS (False)
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub TEST_FOR_BAD_JOB_MUMBERS()
Dim bFound As Boolean
On Error GoTo EXPLAIN
Application.ScreenUpdating = False 'increase performance
Application.DisplayAlerts = False
'Unhide all sheets
Sheets("REPORT").Visible = True
'Unhide all sheets
'Get all of the settings for this macro and assign variables
strpathtofile = Sheets("Options").Range("B3").Value
strFilename = Sheets("Options").Range("B4").Value
strpathtoProj = Sheets("Options").Range("B7").Value
'Get all of the settings for this macro and assign variables
Sheets("REPORT").Select
ActiveSheet.Unprotect
Range("C2").Select
Do Until ActiveCell.Value = ""
bFound = True
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject") 'Wow! What an
efficiency increase!
If Not fso.FileExists(strpathtofile & ActiveCell & strFilename) Then 'Wow!
What an efficiency increase!
Error (53) 'file not found error
End If
ActiveCell.Font.Color = RGB(0, 0, 0)
ActiveCell.Font.Bold = False
ActiveCell.Offset(1, 0).Select
Loop
Range("c2").Select
'Clean up the look of this thing!
Sheets("Options").Visible = False
Sheets("REPORT").Select
If bFound Then
MsgBox "Test Has Passed! All Job Numbers Found on X-Drive"
Else
MsgBox "No Jobs!"
End If
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Exit Sub
EXPLAIN:
'Clean up the look of this thing!
Sheets("Options").Visible = False
Sheets("REPORT").Select
ActiveCell.Font.Color = RGB(255, 0, 0)
ActiveCell.Font.Bold = True
MsgBox "One Or More Jobs Do Not Exist. Please Check for RED Highlighted
Job."
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub IMPORT_ALL_INFORMATION()
'Set variables
Dim file_in As Long
Dim strInput As Variant
'end setting variables
Sheets("REPORT").Select
Range("C2").Select
Do Until ActiveCell.Value = "" '//loop through each job
file_in = FreeFile 'next file number
strFileToOpen = strpathtofile & ActiveCell.Value & strFilename
Open strFileToOpen For Input As #file_in
Put_Data_In_Array (file_in)
Organize_Array_For_Print
Close #file_in ' close the file
file_in = file_in + 1
Sheets("REPORT").Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Judging by the title of your question this is what you need, but I am a little confused by your question:
sub MainSub()
FileOne = worksheets("SuperSecretHiddenSheet").range("A1").value
FileTwo = worksheets("SuperSecretHiddenSheet").range("A2").value
if bothfileExists(FileOne, FileTwo) = true then
'do stuff
end if
End Sub
function bothfileExists(ByRef FileOne as string, ByRef fileTwo as string) as boolean
if (dir(fileone) <> "" and dir(fileTwo) <> "") then
bothfileExists = True
else
bothfileExists = False
end if
end function

Mirror a single table to multiple sheets in excel using vba

I have one table in the database sheet in which i would want to paste link to another sheet. However i realised that it is not possible using excel and vba. Is there any ways to reference these tables automatically? Equating the cell ranges is one way that i know of but it is extremely tedious because i have over 50 tables of such. Hard coding these equations are a trouble.This is a basic code I have done to copy paste a table .
Sub table()
ActiveSheet.ListObjects("Table1").Range.Copy
'This code will run only when the cursor is at activesheet
Sheets("Sheeet2").Range("A2").PasteSpecial xlPasteValues
End Sub
Here is an example of how to add Table Connections to a new Workbook and a way to Refresh the tables.
The code steps through each ListObject in ListObjects (Tables), .Add's the connection to the new Workbook and places the Table into the Worksheet.
It then creates a new Worksheet and process the next ListObject.
You can change the Workbook and Worksheet names + path to your needs.
*Do note that for unknown reasons to me the Table mixes the rownumbers up when placing them into the new Worksheet, it however doesn't mix the Columns.
AddTableConnectionsToNewWB code:
Sub AddTableConnectionsToNewWB()
Dim tbl As ListObject
Dim tblConn As ListObjects
Dim wb As Workbook
Application.ScreenUpdating = False
Set wb = Workbooks("TableConnections.xlsm")
Set tblConn = Workbooks("TestBook3.xlsm").Worksheets("Sheet2").ListObjects
For Each tbl In tblConn
wb.Connections.Add2 "WorksheetConnection_TestBook3.xlsm!" & tbl, _
"", "WORKSHEET;H:\Projects\TestBook3.xlsm", "TestBook3.xlsm!" & tbl, 7, True, _
False
If wb.Worksheets.Count = 1 Then
With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _
Connections("WorksheetConnection_TestBook3.xlsm!" & tbl), Destination:=Range( _
"$A$1")).TableObject
.RowNumbers = False
.PreserveFormatting = True
.RefreshStyle = 1
.AdjustColumnWidth = True
.ListObject.DisplayName = tbl.Name
.Refresh
End With
wb.Worksheets.Add after:=wb.Worksheets(Worksheets.Count)
Else
With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _
Connections("WorksheetConnection_TestBook3.xlsm!" & tbl), Destination:=Range( _
"$A$1")).TableObject
.RowNumbers = False
.PreserveFormatting = True
.RefreshStyle = 1
.AdjustColumnWidth = True
.ListObject.DisplayName = tbl.Name
.Refresh
End With
If tblConn.Item(tblConn.Count).Name <> tbl.Name Then
wb.Worksheets.Add after:=wb.Worksheets(Worksheets.Count)
End If
End If
Next
Application.ScreenUpdating = False
End Sub
Refresh code (this can also be done by simply clicking the refresh all button in Table Tools):
Sub RefreshTableConnections()
Dim wb As Workbook
Application.ScreenUpdating = False
Set wb = Workbooks("TableConnections.xlsm")
wb.RefreshAll
Application.ScreenUpdating = True
End Sub

fName set as Variant, still showing mismatch error when trying to stop macro if no file selected by GetOpenFileName function

I am trying to run my code with GetOpenFileName function in it. When I am not selecting a file, I am unsure of what is the value that is returned in variable fName. The way my code is right now, If I "Do Not" select a file, it returns the message box as written(which is what I want) but as I click ok, it takes me to a random spot in my workbook(something I also need help on), but main issue is, when I "Do" select a file to run, it gives me back a "Type mismatch error" even when my variable is defined as Variant. Without this addition to my code, the code runs great but I want to add this functionality. Thanks in advance for the help!
Dim fName As Variant
fName = Application.GetOpenFilename( _
FileFilter:="*.xlsx(*.xlsx),*.xls,*.xlsm (*.xlsm),*.xlsm", _
Title:="Select a file or files", _
MultiSelect:=True)
If fName = "False" Then
MsgBox "Select a file to proceed"
Else
Sheets("Main").Select
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
' Sub CopyData()
'
' CopyData Macro
'
'
Sheets("Sheet1").Select
Columns("A:O").Select
Selection.Copy
Windows("SupplierDeliveryPerfWall_MasterSheet").Activate
' ActiveSheet.Select
' ActiveSheet.Name = "Data"
Sheets("Data").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
If Not mybook Is Nothing Then
mybook.Close SaveChanges:=True
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
'Insert data validation column
Windows("SupplierDeliveryPerfWall_MasterSheet").Activate
Sheets("Data").Select
Range("A2:O2000").Select
' Unmerge data that is copied from Oracle
Range("A2:O2000").UnMerge
' Sub sbInsertingColumns()
'Inserting a Column at Column E for reason codes
Range("E1").EntireColumn.Insert
Range("E1").Select
ActiveCell.FormulaR1C1 = "Reason Code"
ActiveCell.Offset(1, 0).Range("A1").Select
'Inserting a Column at Column F for Comments
Range("F1").EntireColumn.Insert
Range("F1").Select
ActiveCell.FormulaR1C1 = "Comments"
Range("F1").Select
Application.CutCopyMode = False
' Inserting data validation
Sheets("Main").Select
Range("AF2:AF2000").Select
Selection.Copy
Sheets("Data").Select
Range("E2").Select
ActiveSheet.Paste
' Insert Comment in data validation
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Reason Codes'!$A$2:$A$500"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "Select Reason Code"
.ErrorTitle = "Select from list"
.InputMessage = ""
.ErrorMessage = "If exception, enter in COMMENTS column"
.ShowInput = True
.ShowError = True
End With
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Reason Codes'!$A$2:$A$500"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Select from list"
.InputMessage = "Select Reason Code"
.ErrorMessage = "If exception, enter in COMMENTS column"
.ShowInput = True
.ShowError = True
End With
Next
End If
End Sub
main issue is, when I "Do" select a file to run, it gives me back a "Type mismatch error" even when my variable is defined as Variant.
This is because you have MultiSelect:=True. This is problematic because sometimes the result will be an array and other times (if the user cancels) it will be a boolean. So first you need to test whether the return value is an array or not. If it's an array, the iterate the selected files. If not, then do the MsgBox prompt.
Sub foo()
Dim FileNames
Dim file
FileNames = Application.GetOpenFilename( _
FileFilter:="*.xlsx(*.xlsx),*.xls,*.xlsm (*.xlsm),*.xlsm", _
Title:="Select a file or files", _
MultiSelect:=True)
If IsArray(FileNames) Then
For Each file In FileNames
'Do something to each file
Next
Else
'This really can't be anything other than FALSE:
If Not FileNames Then
MsgBox "No files selected"
Exit Sub
End If
End If
End Sub
If you don't need to allow multi-select, then just use the Dir() function.
fName = Application.GetOpenFilename( _
FileFilter:="*.xlsx(*.xlsx),*.xls,*.xlsm (*.xlsm),*.xlsm", _
Title:="Select a file", _
MultiSelect:=False)
If Dir(CStr(fName)) = vbNullString Then
MsgBox "Select a file to proceed"
Exit Sub
Else
'Do something to the file
End If

Excel Macro works slow, how to make it faster?

Stackovwerflow community.
I do believe that this question was asked x1000 times here, but i just wasn not able to find a solution for my slow macro.
This macro serves for unhiding certain areas on worksheets if correct password was entered. What area to unhide depends on cell value. On Sheet1 i have a table that relates certain cell values to passwords.
Here's the code that i use.
1st. Part (starts on userform named "Pass" OK button click)
Private Sub CommandButton1_Click()
Dim ws As Worksheet
DoNotInclude = "PassDB"
For Each ws In ActiveWorkbook.Worksheets
If InStr(DoNotInclude, ws.Name) = 0 Then
Application.ScreenUpdating = False
Call Module1.Hide(ws)
Application.ScreenUpdating = True
End If
Next ws
End Sub
2nd Part.
Sub Hide(ws As Worksheet)
Application.Cursor = xlWait
Dim EntPass As String: EntPass = Pass.TextBox1.Value
If EntPass = Sheet1.Range("G1").Value Then ' Master-Pass, opens all
Sheet1.Visible = xlSheetVisible
ws.Unprotect Password:="Test"
ws.Cells.EntireRow.Hidden = False
Pass.Hide
Else
Dim Last As Integer: Last = Sheet1.Range("A1000").End(xlUp).Row
Dim i As Integer
For i = 2 To Last
Dim region As String: region = Sheet1.Range("A" & i).Value
Dim pswd As String: pswd = Sheet1.Range("B" & i).Value
If EntPass = pswd Then
ws.Unprotect Password:="Test"
ws.Cells.EntireRow.Hidden = False
Dim b As Integer
Dim Last2 As Integer: Last2 = ws.Range("A1000").End(xlUp).Row
For b = 2 To Last2
ws.Unprotect Password:="Test"
If ws.Range("A" & b).Value <> region Then
ws.Range("A" & b).EntireRow.Hidden = True
End If
If ws.Range("A" & b).Value = "HEADER" Then
ws.Range("A" & b).EntireRow.Hidden = False
End If
ws.Protect Password:="Test"
Next b
End If
Next i
End If
Application.Cursor = xlDefault
Sheet2.Activate
Sheet2.Select
Pass.Hide
End Sub
It works fast enough if I enter master-pass to get access to every hidden area, but if i enter cell.value related password, it takes about 5-6 minutes before macro will unhide required areas on every worksheet.
I'd be really grateful if someone could point out the reasons of slow performance and advise changes to be made in code. Just in case, i've uploaded my excel file here for your convenience.
http://www.datafilehost.com/d/d46e2817
Master-Pass is OPENALL, other passwords are "1" to "15".
Thank you in advance and best regards.
Try batching up your changes:
Dim rngShow as Range, c as range
ws.Unprotect Password:="Test" 'move this outside your loop !
For b = 2 To Last2
Set c = ws.Range("A" & b)
If c.Value = "HEADER" Then
c.EntireRow.Hidden = False
Else
If c.Value <> region Then
If rngShow is nothing then
Set rngShow = c
Else
Set rngShow=application.union(c, rngShow)
End If
End If
End If
Next b
If Not rngShow is Nothing Then rngShow.EntireRow.Hidden = False
ws.Protect Password:="Test" 'reprotect...
You might also want to toggle Application.Calculation = xlCalculationManual and Application.Calculation = xlCalculationAutomatic
You can also try moving your Application.Screenupdating code out of the loop, it's going to update for every sheet as written.
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Application.ScreenUpdating = False ''<- Here
DoNotInclude = "PassDB"
For Each ws In ActiveWorkbook.Worksheets
If InStr(DoNotInclude, ws.Name) = 0 Then
Call Module1.Hide(ws)
End If
Next ws
Application.ScreenUpdating = True ''<- Here
End Sub

Getting Past VBA Error when selecting

I wonder if anybody can help me. I have a macro which selects sheets that are named as employees and puts them into the correct workbook dependant on where they work.
I have made the macro so that it selects all sheets for the depot then copies them into a new workbook.
My problem is when it can't find one of the sheets it skips all of them for that location workbook. and moves to the next location. Is there a way round this so if the macro can't find one of the sheets it moves the rest of them anyway.
Sub BIR()
On Error GoTo Getout
Sheets(Array("Martyn Arthur Lewis", "Norman Stewart Gray")).Move
Sheets.Select
For Each ws In Worksheets
ws.Activate
With ActiveSheet.PageSetup
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 90
.printerrors = xlPrintErrorsBlank
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
End With
Next
ChDir "\\afi-uplift\documents\company\Support Services\Support Services Level 1\Reports\Transport Reports\Vehicle KPI"
ActiveWorkbook.SaveAs Filename:="\\afi-uplift\documents\company\Support Services\Support Services Level 2\Support Services\Transport\Drivers\Driver Performance\BIR Driver KPI " & Format(Date, "yyyy.mm.dd") & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Windows("Driver Report.xlsm").Activate
Getout:
End Sub
I don't understand why people always need to use .select and .activate
First it slows the program, and second, usualy, you don't even need to select/activate.
Doesn't your code work if you write it like this :
option explicit 'forces user to dim variables, , alot easier to find errors
err.clear
on error goto 0 'how can you debug errors with a on error goto (or on error resume next) ?
dim ws as worksheet
For Each ws In Sheets(Array("Martyn Arthur Lewis", "Norman Stewart Gray"))
With ws.PageSetup
'your code
end with
next ws