Excel VBA 2010：用VBA保存工作簿时，数据验证中断，但手动保存时，数据验证不中断

Question

CONTEXT AND WHAT WORKBOOK DOES I have a workbook for creating questionnaires; the user selects from lists of questions across multiple tabs and then runs a macro which collates the selected questions into a new workbook; the user would send the new 'published' workbook to their customer. Response type can also be selected with questions; eg "Yes/No", "1 to 5 score" etc. When the questions and tabs are collated the response type is added on the new workbook as data-validation; the tab with the drop-down lists exists in the new workbook and is hidden.

BEHAVIOUR I'M SEEING Everything works while the workbook is still open following creation; however when I close and re-open I get the standard error "Unreadable content found... Do you want to repair... " The repair by excel removes all the data validation from all tabs! This only happens when the file is created and saved through VBA ; creating and saving files manually I do not get this error. I have also, for example, tried using the same VBA code for adding the data validation, on a new workbook created by myself, and this issue doesn't happen.

Notes on code; workflow, and what I've tried follow:

Code to create and save new workbook

outFileName = Application.GetSaveAsFilename(InitialFileName:=standardName, FileFilter:="Excel Files (*.xlsm), *.xlsm", Title:="Save As")

If outFileName = "FALSE" Then
    MsgBox ("Export NOT completed")
    GoTo endSafely
Else
outFileName = outFileName
End If

Set outBook = Workbooks.Add

'Activate and save the workbook
outBook.Activate
outBook.SaveAs Filename:=outFileName, FileFormat:=52

Code to apply data validation

    Sub addResponseFormatting(targetBook, targetSheet, targetRow, targetColumn, typeResponse)


Set targetBook = Workbooks(targetBook)
Set thisBook = Workbooks(ThisWorkbook.Name)

'---------------------------------------------------------------------------------------------------
'  PROCESS
'---------------------------------------------------------------------------------------------------

targetBook.Activate
targetBook.Sheets(targetSheet).Activate

Dim targetCell As Range

With targetBook.Sheets(targetSheet).Cells(targetRow, targetColumn).Validation


    Select Case typeResponse

        Case "Yes/No"

                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="=DropDowns!$D$4:$D$5"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True


        Case "1 to 5"

                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:="=DropDowns!$C$4:$C$8"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True

        Case Else
            'Do nothing; leave open as free text
            'Removes all validation; note this may also remove tooltip messages if we've applied these
            .Delete
    End Select

End With


End Sub

Workflow

1. Create and save new workbook - "Workbook-B"
2. Copy the 'DropDowns' tab across
3. For each tab in Master Workbook, "Workbook A", if tab flagged as 'Use', copy tab to Workbook-B (no data validation yet; just a list beside each question of what response type is wanted)
4. For each tab in Workbook-B, cut down content on sheet to what customer needs to see (eg removing un-used questions), and apply data validation corresponding to the response type selected
5. Save the workbook again

Things I've tried

• The cells which the validation goes on are merged; I've experimented with a fresh workbook using the same validation code to add validation to merged cells, hiding/showing the Dropdown sheet, applying validation manually vs. with code, and the issue always recurs only if VBA created and saved the workbook
• Saving file as macro/non-macro workbook makes no difference: (xlsx, xlsm)
• Tried copying the code into a new module in case corrupted
• Experimented with specifying/not specifying Excel file type on the .SaveAs command; tried different file type filters

Everything else on file is as expected

Other notes

• Using Excel 2010; file is saved as xlsx; file is opened on Excel 2010 again
• I found another similar thread however the issue there was related to the Drop-down boxes remaining linked to the source workbook; this wouldn't happen in my case (I pre-empted in my code) because there is no datavalidation until the workbook exists and already has all the copied tabs into it; the macro adds the data validation and points it at the DropDowns tab existing in the workbook.

Has anyone else had and fixed this issue?

This is my first post here so I hope I've been thorough. Thankyou.

Answer 1

I found the root of the issue: some other data validation was being copied across with my tabs and their Source (list-type validation) was still linked to the original workbook - this caused an error and when Excel tried to repair the file it would remove all the data validation from a tab (not just that with the error).

To identify which cells gained and lost data validation I used this simple bit of code to highlight cells with validation:

Sub routine (data valdation check function follows)

Sub runascan()

Set targetBook = Workbooks("test25")

targetBook.Activate

For Each sheetsIn In targetBook.Sheets

    sheetsIn.Activate

    For Each cellin In Range("A1:Z100")

        If checkVal(cellin) = 1 Then
            cellin.Interior.Color = RGB(0, 255, 0)
        Else

        End If
   Next cellin

Next sheetsIn

End Sub

Function to check if data validation in a cell

Function checkVal(tRange)

Workbooks(ThisWorkbook.Name).Activate

x = 0
On Error Resume Next
x = tRange.SpecialCells(xlCellTypeSameValidation).Count

On Error GoTo 0

If x = 0 Then
    checkVal = 0
Else
    checkVal = 1
End If

End Function