• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Sheet kopieeren zonder de macro

  • Onderwerp starter Onderwerp starter HWV
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.
HWV

HWV

Terugkerende gebruiker
Lid geworden
19 feb 2009
Berichten
1.213
Beste,

Ik heb een vraag met betreking tot het kopieeren van een sheet en opslaan op een locatie.
De onderstaande code gebruik ik hier voor:

Code: 
Sub Save1()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
Dim Plaatsnaam
Set Plaatsnaam = Worksheets("Bestellijst1").Range("U9")

Dim Naam_Klant
Set Naam_Klant = Worksheets("Bestellijst1").Range("R7")

Dim Debnummer
Set Debnummer = Worksheets("Bestellijst1").Range("R6")

Dim Mydate
    Mydate = Date
Dim Datumtekst
    Datumtekst = CStr(Mydate)

Sheets("Bestellijst1").Select
Sheets("Bestellijst1").Copy
ChDir "P:\Bestellijsten\Bestellijsten\"
ActiveWorkbook.SaveAs Filename:="P:\Bestellijsten\Bestellijsten\" & "" & Naam_Klant & " " & Plaatsnaam & " " & Debnummer & " " & Datumtekst & ".xls", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False

MsgBox "Je gegevens zijn opgeslagen in de map P:\Bestellijsten\Bestellijsten", vbInformation, "Administrator mededeling"
ActiveWorkbook.Close
Sheets("Bestellijst1").Select

Call close_bestanden
Call close_wb
Application.Quit

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Dit doet hij goed maar ik heb in dit blad "Bestellijst1" de volgende code staan die hij nu mee neem naar het gekopieerde sheet.

Ik wil enkel de sheet "Bestellijst1 zonder de macro er in hebben , is dit mogelijk ?"
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
'============================
'Artikelgegevens
'============================
If Target.Column = 2 Then
Target.Offset(, 1).Value = ""
Target.Offset(, 1).Value = Workbooks("PPP artikelbestand.xls").Sheets("Opslag").Columns(1).Find(Target.Value, , xlValues, xlWhole).Offset(, 21).Value
End If
If Target.Column = 2 Then
Target.Offset(, 15).Value = ""
Target.Offset(, 15).Value = Workbooks("PPP artikelbestand.xls").Sheets("Opslag").Columns(1).Find(Target.Value, , xlValues, xlWhole).Offset(, 27).Value
End If
'=============================
'adres gegevens
'=============================
Dim wsFrom As Variant
Set wsFrom = Workbooks("ZNP afnemer1 bewerkt.xls").Sheets("Opslag").Range("A2:BL3000")
If Target.Column = 18 Then
Application.EnableEvents = False
    Target.Offset(1, 0).Value = Application.VLookup(Target.Value, wsFrom, 3, 0)
    Target.Offset(2, 0).Value = Application.VLookup(Target.Value, wsFrom, 5, 0)
    Target.Offset(3, 0).Value = Application.VLookup(Target.Value, wsFrom, 6, 0)
    Target.Offset(3, 1).Value = Application.VLookup(Target.Value, wsFrom, 7, 0)
    Target.Offset(4, 0).Value = Application.VLookup(Target.Value, wsFrom, 10, 0)
   End If
Application.EnableEvents = True
'============================
'opmaak
'============================
If Target.Column <> 2 Then Exit Sub
Application.ScreenUpdating = False
Range(Cells(Target.Row, "B"), Cells(Target.Row, "AA")).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous 'xlDouble
.Weight = xlThin 'xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous 'xlDouble
.Weight = xlThin 'xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

If Target.Column <> 2 Then Exit Sub
Application.ScreenUpdating = False
Range(Cells(Target.Row, "A"), Cells(Target.Row, "A")).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous 'xlDouble
.Weight = xlThin 'xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous 'xlDouble
.Weight = xlThin 'xlThick
.ColorIndex = xlAutomatic
End With

If Target.Column <> 2 Then Exit Sub
Application.ScreenUpdating = False
Range(Cells(Target.Row, "AB"), Cells(Target.Row, "AB")).Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous 'xlDouble
.Weight = xlThin 'xlThick
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous 'xlDouble
.Weight = xlThin 'xlThick
.ColorIndex = xlAutomatic
End With
Target.Select
Application.ScreenUpdating = True
End Sub

Alweer vast bedankt voor uw medewerking

Groet HWV
 
Geprobeerd en gefaald

Code: 
Sub Save1()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
Dim Plaatsnaam
Set Plaatsnaam = Worksheets("Bestellijst1").Range("U9")

Dim Naam_Klant
Set Naam_Klant = Worksheets("Bestellijst1").Range("R7")

Dim Debnummer
Set Debnummer = Worksheets("Bestellijst1").Range("R6")

Dim Mydate
    Mydate = Date
Dim Datumtekst
    Datumtekst = CStr(Mydate)

Sheets("Bestellijst1").Select
Sheets("Bestellijst1").Copy

Dim sSheet As Object, strName As String

        For Each sSheet In Sheets

            Select Case UCase(sSheet.Name)

                Case "Bestellijst1"

                    strName = sSheet.CodeName
                    

                    With ThisWorkbook.VBProject.VBComponents(strName).CodeModule

                            .DeleteLines 1, .CountOfLines

                    End With
               Case Else
                   'Whatever
          End Select
      

        Next sSheet


ChDir "P:\Bestellijsten\Bestellijsten\"
ActiveWorkbook.SaveAs Filename:="P:\Bestellijsten\Bestellijsten\" & "" & Naam_Klant & " " & Plaatsnaam & " " & Debnummer & " " & Datumtekst & ".xls", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False

MsgBox "Je gegevens zijn opgeslagen in de map P:\Bestellijsten\Bestellijsten", vbInformation, "Administrator mededeling"
ActiveWorkbook.Close
Sheets("Bestellijst1").Select

Call close_bestanden
Call close_wb
Application.Quit

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Rudi,

Code geplaats waar ik denk dat deze moet komen.
Eerst het blad copy en daar tussen de code weg halen.
Geprobeerd maar krijg het niet voor elkaar . Vergeet ik wat.

Groet Henk
 
Probeer deze eens

Mvg

Rudi
 

Bijlagen

Fout melding

Rudi, jou code geprobeerd gaf hij een fout aan

Compileerfout
Object vereist:

Code: 
End With
Set Plaatsnaam = [Bestellijst1!U9]
Set Naam_Klant = [Bestellijst1!R7]
Set Debnummer = [Bestellijst1!R6]
Datumtekst = CStr(Date)
Sheets("Bestellijst1").Copy

Toen heb ik het volgende geprobeerd:

Code: 
Sub Save1()

Dim Plaatsnaam
Set Plaatsnaam = Worksheets("Bestellijst1").Range("U9")

Dim Naam_Klant
Set Naam_Klant = Worksheets("Bestellijst1").Range("R7")

Dim Debnummer
Set Debnummer = Worksheets("Bestellijst1").Range("R6")

Dim Mydate
    Mydate = Date
Dim Datumtekst
    Datumtekst = CStr(Mydate)

Sheets("Bestellijst1").Copy
Dim strName As String
    strName = ActiveSheet.CodeName
    

    With ActiveWorkbook.VBProject.VBComponents(strName).CodeModule
            .DeleteLines 1, .CountOfLines
    End With
ChDir "P:\Bestellijsten\Bestellijsten\"
ActiveWorkbook.SaveAs "P:\Bestellijsten\Bestellijsten\" & "" & Naam_Klant & " " & Plaatsnaam & " " & Debnummer & " " & Datumtekst & ".xls", _
        xlNormal, "", "", False, False
MsgBox "Je gegevens zijn opgeslagen in de map P:\Bestellijsten\Bestellijsten", vbInformation, "Administrator mededeling"
ActiveWorkbook.Close
Sheets("Bestellijst1").Select
Call close_bestanden
Call close_wb
With Application
    .Quit
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub


Fout 1004 tijdens uitvoering
Toegang tot het visual Basic-project op programmeernivuau is niet betrouwbaar
Code: 
With ActiveWorkbook.VBProject.VBComponents(strName).CodeModule
            .DeleteLines 1, .CountOfLines

Is ingewikkelde als dat ik in eerste instantie dacht

Groet Henk
 
Hou het simpel:

maak een nieuw werkblad
kopieer de inhoud van het werkblad dat opgeslagen moet worden naar dat nieuwe werkblad. Sla dat nieuwe werkblad op.
 
Beide werken bij mij zonder fout

Mvg

Rudi
 

Bijlagen

Code: 
Sub Save1()
  with workbooks.add
     with .sheets(1)
       [COLOR="Red"]Thisworkbook.[/COLOR]sheets([COLOR="red"]"Bestellijst1"[/COLOR]).usedrange.copy .[A1]
      .parent.saveas "P:\Bestellijsten\Bestellijsten\" & .[R7] & " " & .[U9] & " " & .[R6]  & format(date," yyyymmdd") & ".xls"
    end with    
   .close
  end with
End Sub
 
Laatst bewerkt:
Kan ook de opmaak meegenomen worden

Beste Rudi en SNB,

Rudi

Ik heb de bestanden van Rudi nogmaals geprobeerd en ik krijg bij de eerst script nog steeds de zelfde fout:

Bij het tweede script liep hij nu wel door en slaat inderdaad nu wel de gegevens in de naam goed op, enkel hij heeft de gegevens niet meegenomen want nu is het een lege sheet die is opgeslagen onder die naam.

SNB

Script gaat goed enkel met de volgende opmerkingen.
- Hij neem de opmaak niet mee van het te blad wat gekopieerd dient te worden.
- Debnummer en naam neemt hij niet mee. R6 en R7
(Dit zal waarschijnlijk liggen dat R6 samengevoegde cellen zijn en dit geld ook voor R7)

Ik heb in de bijlage een soort gelijke bestelformulier gedaan zonder de bedrijfsgegevens en logo. Deze sheet wil ik dus kopieeren met opmaak zonder de macro`s erin.
Tevens een voorbeeld hoe hij nu de gegevens heeft gekopieerd maar dan zonder debnr en naam in de omscrijving met opslaan. Maar dit zou bv met een verwijzing opgelost kunnen worden.

Beiden alvast bedankt voor de input en hoop dat jullie mij hier verdere mee willen en kunnen helpen.

Groet Henk
 

Bijlagen

Code: 
Sub Save1()
  With Workbooks.Add
     With .Sheets(1)
[COLOR="Red"][U]Sheets("blad1").UsedRange .[A1][/U][/COLOR]
      .Parent.SaveAs "D:\" & .[R7] & " " & .[U9] & " " & .[R6] & Format(Date, " yyyymmdd") & ".xls"
    End With
   .Close
  End With
End Sub

HIj geef een foutmelding op bovenstaande de melding is
Onjuist aantal argumenten of ongeldige eigenschappentoewijzing.

HIj maak al wel een nieuw blad aan maar doet geen copy maken en opslaan.

Groet Henk
 
Is kopiëren en plakken zo moeilijk ?
 
Laatst bewerkt:
Geprobeerd

Beste,

Ik ben aan het proberen geweest en gekeken waaraan het aan kon liggen.
Code: 
Sub Save1()
  With Workbooks.Add
     With .Sheets(1)
       Sheets("Blad 1").UsedRange.Copy .[A1]
      .Parent.SaveAs "P:\Bestellijsten\Bestellijsten\" & .[R7] & " " & .[U9] & " " & .[R6] & Format(Date, " yyyymmdd") & ".xls"
    End With
   .Close
  End With
End Sub

Volgens mij kopieert hij nu de opgegeven sheet, maar waar het gedeelte "paste" nu zou moeten komen te staan zou ik niet weten.

Ik hoop dat u mij hier verder in kunt en wil helpen.

Groet Henk
 
Deze code kopieert en plakt in 1 keer (zie de hulpfunktie van de VBEditor). Meer code heb je niet nodig.
Hier nog wat toegevoegd.
 
Laatst bewerkt:
Aangepast

Beste,

Ik heb de code gecopieerd van uw sugestie.
Enkel omdat ik nu op een andere locatie zit de doel P: veranderd in mijn D schijf.

Code: 
Sub Save1()
  With Workbooks.Add
     With .Sheets(1)
       ThisWorkbook.Sheets("Bestellijst1").UsedRange .[A1]
      .Parent.SaveAs "D:\" & .[R7] & " " & .[U9] & " " & .[R6] & Format(Date, " yyyymmdd") & ".xls"
    End With
   .Close
  End With
End Sub

Toch geef hij de code fout 450 tijdens uitvoering
Onjuiste aantal argumenten of ongeldige eigenschappentoewijzing

Helaas krijg ik het niet werkend

In de bijlage een test voor de code

Groet HWV
 

Bijlagen

Laatst bewerkt:
Waar is die Thisworkbook gebleven dan ?
En waar is de opdracht copy gebleven ?
 
Laatst bewerkt:
Aangepast

De code is in de vorige aangepast gelijk als in de bijlage, daar staat Thisworkbook wel vermeld

Copy heb ik weggehaald naar aanleiding van het volgende :

Deze code kopieert en plakt in 1 keer (zie de hulpfunktie van de VBEditor). Meer code heb je niet nodig.
Hier nog wat toegevoegd.
Klik om te vergroten...

HWV
 
Gebruik deze code zonder er iets aan te wijzigen:

Code: 
Sub Save1()
  With Workbooks.Add
     With .Sheets(1)
       Thisworkbook.sheets("Bestellijst1").usedrange.copy .[A1]
      .Parent.SaveAs "D:\" & .[R7] & " " & .[U9] & " " & .[R6]  & format(date," yyyymmdd") & ".xls"
    End With    
    .Close
  End with
End Sub

PS en zorg er in het blad bestellijst1 voor dat er geen lege regels voorkomen voor rij 6.
 
Laatst bewerkt:
Complimenten

Beste SNB,

Het is gelukt complimenten hiervoor, ik had hier nooit uitgekomen.
Hij kopieer de opmaak, de waarde`s maar hij neem niet de kolom breedte over.
Is dit ook in te bouwen.
in de bijlage van hoe het er nu uiteindelijk eruitkomt te zien.
Groet Henk
 

Bijlagen

Stap verder

Beste,

Ik ben voor mij zelf al weer een stap verder gekomen met het script.
Code: 
Sub Savetest()
  With Workbooks.Add
     With .Sheets(1)
       ThisWorkbook.Sheets("Bestellijst1").Range("A:AB").Copy .[A1]
      .Parent.SaveAs "P:\Bestellijsten\Bestellijsten\" & .[R7] & " " & .[U9] & " " & .[R6] & Format(Date, " dd-mm-yyyy") & ".xls"
    End With
    .Close
  End With
End Sub

Ik heb de regel :
Code: 
Thisworkbook.sheets("Bestellijst1").usedrange.copy .[A1]

Veranderd in :
Code: 
       ThisWorkbook.Sheets("Bestellijst1").Range("A:AB").Copy .[A1]

Op deze manier neem hij wel de kolombreedte mee, en secelteer enkel het gebied dat ik over wil zetten.

Nu nog het probleem dat hij niet de rij hoogte meeneem, en de instellingen voor printen van de bestellijst.
Hier kom ik nu net achter vandaar dat ik dit nog niet eerder in de vraagstelling heb meegenomen.

Ik hoop dat ik hier ondersteuning in kan krijgen

groet Henk
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan