Compatibiliteitscontrole omzeilen

[bertkt]

Hallo,

Ik heb een workbook met verschillende tabbladen.
Via een macro wil ik alle tabbladen die beginnen met "R0" apart laten opslaan als een bestandje.
Zelf heb ik al iets uit mijn mouw proberen schudden en alles werkt redelijk goed,
maar bij elk bestandje dat wordt "opgeslagen als" treedt er een compatibiliteitscontrole op en deze zou ik willen omzeilen.
De compatibiliteitscontrole (zie bijlage) geeft een melding over het gebruik van tabelstijlen.

't Liefst had ik gezien dat het vinkje "Compatibiliteit controleren bij opslaan van deze werkmap" werd afgevinkt en dat er daarna op doorgaan wordt geklikt.

Hoe moet ik dit oplossen in VBA?

Sub loopSheetsTOS()  'Tabbladen opslaan als

    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        
        If Left(ws.Name, 2) = "R0" Then
        
            ws.Select
            Call tabbladOpslaanAls(ws)
            Range("A1").Select
            
        End If
    Next ws
    
End Sub

Sub tabbladOpslaanAls(ByVal ws As Worksheet)
    Dim strPad As String
    Dim strName As String
    Dim strFileName As String
    
    strPad = "E:\Documentering - BKI\TO USE"
    
    strName = ActiveSheet.Name
    Set ws = ActiveSheet
    
    strFileName = strName & ".xls"
    ws.Copy
    Application.WindowState = xlMinimized
    ChDir strPad
    
    If CInt(Application.Version) <= 11 Then
        ActiveWorkbook.SaveAs Filename:= _
        MyFileName, _
        ReadOnlyRecommended:=False, _
        CreateBackup:=False
    Else
        ActiveWorkbook.SaveAs Filename:= _
        strFileName, FileFormat:=xlExcel8, _
        ReadOnlyRecommended:=False, _
        CreateBackup:=False
    End If
    ActiveWorkbook.Close
End Sub

 

[OctaFish]

Je zou de compatibility check tijdelijk uit kunnen zetten:

    If CInt(Application.Version) <= 11 Then
        With ActiveWorkbook
            .CheckCompatibility = False
            .SaveAs FileName:=MyFileName
            .CheckCompatibility = True
        End With
    Else
        ActiveWorkbook.SaveAs FileName:=strFileName, FileFormat:=xlExcel8
    End If

 

[dnties]

Met alle respect, maar is een vraag die via Google te onderzoeken is.
Ik kwam o.a. deze link tegen, op het Helpmij forum. Kijk daar eens naar.
EDIT: Ik zie OctaFish met deze oplossing zojuist.

Daarnaast zou het volgende kunnen helpen (niet getest, geldt dan meteen voor alle Excel bestanden van de huidige gebruiker):
1.Click Start, click Run, type regedit, and then click OK.
2.Locate and then click the following registry subkey: HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Excel\Options

1.On the Edit menu, point to New, and then click DWORD Value.
2.Type ShowCompatDialog, and then press ENTER.
3.Right-click ShowCompatDialog, and then click Modify.
4.In the Value data box, type 0, and then click OK.
5.On the File menu, click Exit to exit Registry Editor.

NOTE: Kan zijn (als je een nieuwere versie van Outlook gebruikt dan 2007) dat het in
HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Excel\Options
moet worden toegevoegd.

Tijs.

 

[OctaFish]

Niet iedereen zoekt even makkelijk

 

[dnties]

[off-topic]
@OctaFish: Mwah, als je VBA kunt programmeren dan zou je toch ook moeten googelen naar: compatibiliteitscontrole uitschakelen excel
Bovendien was bij het zoeken hier op het Helpmij forum op compatibitiliteitscontrole de oplossing ook boven water gekomen, dus google was niet eens noodzakelijk.
Ik had verwacht bij een VBA-programmeur van enige kwaliteit [zoals de TS is, naar mijn inschatting] dat hij daar toe in staat is.
Hints richting Google of de zoekfunctie van Helpmij geef ik maar heel zelden hier op het forum, maar in dit geval leek me die 'terecht' om redenen die ik hierboven aangaf.

Tijs.
[/off-topic]

 

[OctaFish]

@dnties:
Ik kan niet zeggen dat ik je ongelijk geef; de oplossing was (was mij betreft) redelijk simpel te vinden. Maar een antwoordje is soms net zo snel in elkaar getimmerd als een verhaal over hoe je moet zoeken

 

[dnties]

@OctaFish: Dat klopt en ik heb de links / informatie alsnog voor de TS gepost in mijn eerste posting.

Tijs.

 

[bertkt]

Hallo,

Helaas werkt het allemaal niet. (dat met het register heb ik niet geprobeerd omdat het de bedoeling is dat dit VBA'tje op andere PC's zal werken)
Hij heeft me nog steeds de compatibiliteitscontrole.

Dit is de code op dit moment:

Sub loopSheetsTOS()  'Tabbladen opslaan als

    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        
        If Left(ws.Name, 2) = "R0" Then
        
            ws.Select
            Call tabbladOpslaanAls(ws)
            Range("A1").Select
            
        End If
    Next ws
    
End Sub

Sub tabbladOpslaanAls(ByVal ws As Worksheet)
    Dim strMPad As String
    Dim strPad As String
    Dim strName As String
    Dim strFileName As String
    
    strMPad = ThisWorkbook.Path
    strPad = strMPad & "\Kasten"              'strPad = "E:\Documentering - BKI\TO USE"
    
    strName = ActiveSheet.Name
    
    strFileName = strName & ".xls"
    ws.Copy
    ChDir strPad
    
    If CInt(Application.Version) <= 11 Then
        With ActiveWorkbook
            .CheckCompatibility = False
            .SaveAs Filename:=strFileName
            .CheckCompatibility = True
        End With
    Else
        With ActiveWorkbook
            .CheckCompatibility = False
            .SaveAs Filename:=strFileName, FileFormat:=xlExcel8
            .CheckCompatibility = True
        End With
    End If

    ActiveWorkbook.Close
    Set ws = ActiveSheet
End Sub

 

[bertkt]

Inmiddels heb ik het weten "op te lossen"... nuja "oplossen" zou ik het niet noemen.

Sub loopSheetsTOS()  'Tabbladen opslaan als

    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        
        If Left(ws.Name, 2) = "R0" Then
        
            ws.Select
            Call tabbladOpslaanAls(ws)
            Range("A1").Select
            
        End If
    Next ws
    
End Sub

Sub tabbladOpslaanAls(ByVal ws As Worksheet)
    Dim strMPad As String
    Dim strPad As String
    Dim strName As String
    Dim strFileName As String
    
    strMPad = ThisWorkbook.Path
    strPad = strMPad & "\Kasten"              'strPad = "E:\Documentering - BKI\TO USE"
    
    strName = ActiveSheet.Name
    
    strFileName = strName & ".xls"
    ws.Copy
    ChDir strPad
    
    If CInt(Application.Version) <= 11 Then
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=strFileName
        Application.DisplayAlerts = True
    Else
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=strFileName, FileFormat:=xlExcel8
        Application.DisplayAlerts = True
    End If

    ActiveWorkbook.Close
    Set ws = ActiveSheet
End Sub

 

[dnties]

a. Ik zie zo snel geen verschil tussen de code van je laatste posting en de posting daarvoor?
b. Als je niet verwacht dat we, hier op het forum, nog een andere/beter oplossing voor je weten, dan graag de vraag op opgelost zetten door te klikken op "Zet status opgelost" op de donkerblauwe horizontale balk, bijna bovenaan deze webpagina.

Tijs.

 

[snb]

Sub loopSheetsTOS()
  For Each sh In ActiveWorkbook.sheets
    If Left(sh.Name, 2) = "R0" Then
       sh.copy
       with activeworkbook
         .CheckCompatibility = False
         .saveas thisworkbook.path & "\kasten" & activeworkbook.sheets(1).name & ".xls",56
         .CheckCompatibility = true
         .close 0
       end with
    End If
  Next
End Sub

 

[bertkt]

@dnties: Dit is wat veranderde: Application.DisplayAlerts = False & Application.DisplayAlerts = True

Mijn probleem is nu alvast opgelost!
Bedankt aan ieder!