VBA vraag ActiveSheet.Copy

oceanrace · 31 aug 2010

Hallo forummers,

Ik heb overal gezocht maar ik kom er niet uit.
Deze code kopieert alle gebruikte cellen in het werkblad.

Code:

    ActiveSheet.Copy
    With ActiveWorkbook
    With .Sheets("blahblah")
        .Unprotect "ww"
        .UsedRange.Value = .UsedRange.Value
        .Protect "ww"
    End With
    .SaveAs Filename:=strFileName

Is het mogelijk om in plaats van allle gebruikte cellen een selectie te maken?
Ik zou graag ("A1:B56") willen kopieren ipv alle gebruikte cellen.

Roncancio · 31 aug 2010

Vervang:

Code:

        .UsedRange.Value = .UsedRange.Value

Door:

Code:

        .Range("A1:B56").Value = .Range("A1:B56").Value

Met vriendelijke groet,

Roncancio

oceanrace · 31 aug 2010

Hallo Roncancio,

Ik zal het proberen, maar de vorige keer kreeg ik daarmee een foutmelding.
Hetzelfde regeltje had ik namelijk al eens geprobeerd

Bedankt.

Roncancio · 31 aug 2010

Is het mogelijk om in plaats van allle gebruikte cellen een selectie te maken?
Ik zou graag ("A1:B56") willen kopieren ipv alle gebruikte cellen.[/QUOTE]

Als je alleen maar een bereik wilt kopiëren, volstaat onderstaande code:

Code:

Sub Verplaatsen()
Worksheets(2).Range("A1:B56").Value = Worksheets(1).Range("A1:B56").Value
End Sub

Het bereik A1:B56 van het 1e werkblad wordt gekopieerd naar het 2e werkblad.

Met vriendelijke groet,

Roncancio

oceanrace · 31 aug 2010

Dit is de hele code, hij slaat dus heel werkblad "kaart" op zonder formules (alleen waarden). Daarna vraagt hij of ik wil printen, dan sluit het het nieuwe opgeslagen bestand af. Dit werkt perfect.
Het enige wat veranderd zou moeten worden is dat hij niet het hele blad opslaat maar een selectie. A1:AB56
Ik dacht zelf ook eerst om .UsedRange.Value = .UsedRange.Value aan te passen in je eerste antwoord maar dat werkt niet goed.

Code:

Sub Opslaanzonderformules()
  Dim strFileName As Variant
  Dim strPath As String
  strFileName = Range("AJ2").Value
  strFileName = Application.GetSaveAsFilename(InitialFileName:=strPath & strFileName, _
                                              FileFilter:="Excel Files (*.xls), *.xls, Excel 2007 Files (*.xlsm), *.xslm", _
                                              FilterIndex:=1, _
                                              Title:="Kies de juiste map en pas eventueel de bestandsnaam aan!")
  If strFileName = False Then
    MsgBox "De kaart is niet opgeslagen!", vbInformation + vbOKOnly, "Er is iets misgegaan..."
  Else
    ActiveSheet.Copy
    With ActiveWorkbook
    With .Sheets("kaart")
        .Unprotect "ww"
        .UsedRange.Value = .UsedRange.Value
        .Protect "ww"
    End With
    .SaveAs Filename:=strFileName
End With
  A = MsgBox("Wil je de kaart printen? Maak een keuze, de opgeslagen kaart wordt vervolgens afgesloten om terug te gaan naar het origineel. ", vbQuestion + vbYesNo, "Gelukt, de kaart is opgeslagen!")

If A = vbYes Then
    
Application.Dialogs(xlDialogPrint).Show



End If
     
     ActiveWorkbook.Close Savechanges:=False



  End If
End Sub

Roncancio · 31 aug 2010

Code:

Sub Opslaanzonderformules()
Dim strFileName As Variant
Dim strPath As String
    strFileName = Range("AJ2").Value
    strFileName = Application.GetSaveAsFilename(InitialFileName:=strPath & strFileName, _
                                              FileFilter:="Excel Files (*.xls), *.xls, Excel 2007 Files (*.xlsm), *.xslm", _
                                              FilterIndex:=1, _
                                              Title:="Kies de juiste map en pas eventueel de bestandsnaam aan!")
    If strFileName = False Then
        MsgBox "De kaart is niet opgeslagen!", vbInformation + vbOKOnly, "Er is iets misgegaan..."
    Else
'        ActiveSheet.Copy
        With ActiveWorkbook
            With .Sheets("kaart")
                .Unprotect "ww"
                .Range("A1:AB56").Value = ActiveSheet.Range("A1:AB56").Value
                .Protect "ww"
            End With
            .SaveAs Filename:=strFileName
        End With
        A = MsgBox("Wil je de kaart printen? Maak een keuze, de opgeslagen kaart wordt vervolgens afgesloten om terug te gaan naar het origineel. ", vbQuestion + vbYesNo, "Gelukt, de kaart is opgeslagen!")

        If A = vbYes Then

            Application.Dialogs(xlDialogPrint).Show
        End If
        ActiveWorkbook.Close Savechanges:=False
    End If
End Sub

Ik heb de code zo min mogelijk aangepast.
Het bereik A1 t/m AB56 wordt gekopieerd naar het werkblad "kaart".

Met vriendelijke groet,

Roncancio

oceanrace · 31 aug 2010

Bedankt, ik ga het morgen proberen.

Een goede nacht toegewenst!

oceanrace · 31 aug 2010

Ik heb de code zo min mogelijk aangepast.
Het bereik A1 t/m AB56 wordt gekopieerd naar het werkblad "kaart".

Met vriendelijke groet,

Roncancio

P.s.: het is de bedoeling dat A1:AB56 van werkblad "kaart" naar een nieuwe werkmap worden gekopieerd.
dus niet naar werkblad "kaart"

oceanrace · 1 sep 2010

Het selecteren van een range in een werkblad werkt niet echt.
Met ActiveSheet.copy wordt blijkbaar het hele werkblad gekopieerd naar een nieuwe werkmap.

Moet ik misschien iets van ActiveRange gebruiken hiervoor?

Warme bakkertje · 2 sep 2010

Code:

Sub Opslaanzonderformules()
Dim strFileName As Variant
Dim strPath As String
    strFileName = Range("AJ2").Value
    strFileName = Application.GetSaveAsFilename(InitialFileName:=strPath & strFileName, _
                                              FileFilter:="Excel Files (*.xls), *.xls, Excel 2007 Files (*.xlsm), *.xslm", _
                                              FilterIndex:=1, _
                                              Title:="Kies de juiste map en pas eventueel de bestandsnaam aan!")
    If strFileName = False Then
        MsgBox "De kaart is niet opgeslagen!", vbInformation + vbOKOnly, "Er is iets misgegaan..."
    Else
        Set sourcedata = ActiveSheet.[A1:AB56]
        Workbooks.Add
        With ActiveSheet
            sourcedata.Copy .Range("A1")
            .UsedRange.Value = .UsedRange.Value
        End With
        ActiveWorkbook.SaveAs Filename:=strFileName
        End With
        A = MsgBox("Wil je de kaart printen? Maak een keuze, de opgeslagen kaart wordt vervolgens afgesloten om terug te gaan naar het origineel. ", vbQuestion + vbYesNo, "Gelukt, de kaart is opgeslagen!")

        If A = vbYes Then

            Application.Dialogs(xlDialogPrint).Show
        End If
        ActiveWorkbook.Close Savechanges:=False
    End If
End Sub

oceanrace · 2 sep 2010

Met de laatste oplossing veranderd de pagina indeling van 75% naar 100% en is het een staande pagina geworden in plaats van liggend... :shocked:

Mijn originele code werkt verder prima behalve dat ik telkens een melding krijg:
"Er zijn onvoldoende bronnen beschikbaar om deze taak uit te voltooien. Kies minder gegevens of sluit andere toepassingen."

Weet iemand hoe dat kan?

Warme bakkertje · 3 sep 2010

Met de laatste oplossing veranderd de pagina indeling van 75% naar 100% en is het een staande pagina geworden in plaats van liggend

Dat is nu 1maal het nadeel van slechts een bereik te kopieëren ipv het volledige blad (waarbij alle instellingen mee overgenomen worden).
Je kan toch in je macro de zoomfactor en oriëntatie instellen voor het gekopieërde bereik.

oceanrace · 3 sep 2010

Bedankt voor de tip
Ik zal eens uitvogelen hoe dat moet.

Dat van die " onvoldoende bronnen beschikbaar om deze taak uit te voltooien " krijg ik alleen in excel 2003 in 2007 komt die melding niet...

Ginger · 4 sep 2010

oceanrace zei:
Met de laatste oplossing veranderd de pagina indeling van 75% naar 100% en is het een staande pagina geworden in plaats van liggend... :shocked:

...en...

oceanrace zei:
P.s.: het is de bedoeling dat A1:AB56 van werkblad "kaart" naar een nieuwe werkmap worden gekopieerd.
dus niet naar werkblad "kaart"

Maar dan kan je toch gebruik maken van deze wetenschap?! Kopieer je hele sheet naar een nieuwe map zodat je instelilingen mee over worden genomen. Gooi dan vervolgens de kolommen én regels weg uit die nieuwe sheet die je niet meer wilt gebruiken. Klaar ben je...

Groet, Leo

oceanrace · 20 okt 2010

Goedenavond!
Nog even terugkomend op dit topic.
Hoe kan ik in onderstaande code toevoegen dat ik vanaf kolom AC en vanaf rij 49 alles wil verwijderen?
Ik wil dus t/m kolom AB en rij 48 opslaan.

Code:

Sub Opslaanzonderformules()
  Dim strFileName As Variant, strPath As String
  Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent, CodeMod As VBIDE.CodeModule
  Dim astrLinks As Variant
  strFileName = Application.GetSaveAsFilename(InitialFileName:=strPath & [AG2], _
                                              FileFilter:="Excel Files (*.xls), *.xls, Excel 2007 Files (*.xlsm), *.xslm", _
                                              FilterIndex:=1, _
                                              Title:="Opslaan als excel document (alleen werkblad kaart zonder formules)")
  If strFileName = False Then

    MsgBox "De kaart is niet opgeslagen!", vbInformation + vbOKOnly, "Er is iets misgegaan..."
  Else
      ActiveSheet.Copy
      With ActiveWorkbook
      With .Sheets("kaart")
        .Unprotect "xxx"
        .UsedRange.Value = .UsedRange.Value
        .Protect "xxx"
      End With
      
    ' Define variable as an Excel link type.
    astrLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)

    ' Break the first link in the active workbook.
    For i = 1 To UBound(astrLinks)

    
    ActiveWorkbook.BreakLink _
        Name:=astrLinks(i), _
        Type:=xlLinkTypeExcelLinks
     Next i
     Set VBProj = .VBProject
     For Each VBComp In VBProj.VBComponents
            If VBComp.Type = vbext_ct_Document Then
                Set CodeMod = VBComp.CodeModule
                With CodeMod
                    .DeleteLines 1, .CountOfLines
                End With
            Else
                VBProj.VBComponents.Remove VBComp
            End If
        Next VBComp
    .SaveAs Filename:=strFileName

      End With
      A = MsgBox("Wil je de kaart printen? Maak een keuze, de opgeslagen kaart wordt vervolgens afgesloten om terug te gaan naar het origineel. ", vbQuestion + vbYesNo, "Gelukt, de kaart is opgeslagen!")

      If A = vbYes Then
    
          Application.Dialogs(xlDialogPrint).Show
      End If
      ActiveWorkbook.Close Savechanges:=False
  End If
End Sub

Warme bakkertje · 23 okt 2010

Code:

With .Sheets("kaart")
        .Unprotect "xxx"
        .UsedRange.Value = .UsedRange.Value
        Union(.Range(.Cells(49, 1), .Cells(.Rows.Count, .Columns.Count)), _
            .Range(.Cells(1, 29), .Cells(48, .Columns.Count))).ClearContents
        .Protect "xxx"
End With

oceanrace · 23 okt 2010

Bedankt,
Hij maakt de juiste cellen nu leeg.
Zou je ze ook compleet kunnen verwijderen incl. opmaak?

11221122 · 23 okt 2010

Code:

Range("HIER-JOU-RANGE").Select
    Selection.ClearContents

Ik gebruik in een formule van mij deze code om de cel leeg te maken en de opmaak te verwijderen. Ik weet niet of dit bij jouw zal werken maar het is een proberen waard!

oceanrace · 23 okt 2010

Ik dacht zelf meer aan iets met:

.EntireRow.Delete
.EntireColumn.Delete

11221122 · 23 okt 2010

Ik heb net zelf even exel geopend en wat geprobeerd. Met deze code verwijderd hij ook de opmaak:

Code:

Range("HIER-JOU-RANGE").Select
    Selection.Delete

VBA vraag ActiveSheet.Copy

Gebruiker

Meubilair

Gebruiker

Meubilair

Gebruiker

Meubilair

Gebruiker

Gebruiker

Gebruiker

Meubilair

Gebruiker

Meubilair

Gebruiker

Terugkerende gebruiker

Gebruiker

Meubilair

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Wij waarderen jouw privacy