• 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.

Hulp gezocht macro knop

Status
Niet open voor verdere reacties.
zo doet hij precies wat ik graag wil.

ik kom er alleen achter als ik blad1 beveilig dat hij het dan niet doet :(
ik wil het werkblad waar de kopieën in staan ook beveiligen of kan dat helemaal niet met marco`s

sorry heb echt geen idee en verstand van macro`s
 
Laatst bewerkt:
Met of zonder wachtwoord?
 
Het rode gedeelte.
Code: 
Sub hsv()
Application.ScreenUpdating = False
With Sheets("blad1")
 [COLOR=#ff0000].unprotect "Jewachtwoordhier"[/COLOR]
 If IsError(Evaluate("'" & Format(.Range("K4"), "mmmm yy") & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = Format(.Range("k4"), "mmmm yy")
   .Range("A1:N30").Copy
   Sheets(Format(.Range("K4"), "mmmm yy")).Rows(1).Resize(30).Insert xlDown
   Sheets(Format(.Range("K4"), "mmmm yy")).Cells(1).PasteSpecial 12
   .Range("c8:i8") = Sheets(Format(.Range("K4"), "mmmm yy")).Range("c10:i10").Value
   .Range("k8:n8") = Sheets(Format(.Range("K4"), "mmmm yy")).Range("k10:n10").Value
   .ExportAsFixedFormat 0, "c:\temp\" & .Range("k4").Value
    With CreateObject("Outlook.Application").CreateItem(0)
      .To = ""
      .Subject = "Machinekamerrapport"
      .attachments.Add "c:\temp\" & Sheets("blad1").Range("k4").Value & ".pdf"
      .display '(voor directe versturen gebruik je) .send
    End With
 Kill "c:\temp\" & .Range("k4").Value & ".pdf"
  .Range("k9").Resize(, 4).ClearContents
  .Range("c10").Resize(, 8).ClearContents
  .Range("b12:n20,b22:n30").ClearContents
  [COLOR=#ff0000].protect "Jewachtwoordhier"[/COLOR]
End With
End Sub
 
:thumb::thumb::thumb:
heel erg bedankt voor het geduld en alle hulp.
 
Graag gedaan.
 
we gebruiken het bestand nou 3 dagen en ben er achter gekomen dat er toch nog een kleine fout in zit.

in het pdf bestand dat in de mail als bijlage staat, neemt de gegevens van cellen C8:I8 en C9:I9 niet over.
en is het ook mogelijk dat hij de pdf direct afdrukt wanneer deze naar de mail wordt gestuurd?

Code: 
Sub hsv()
Application.ScreenUpdating = False
With Sheets("blad1")
.Unprotect "wachtwoord"
 If IsError(Evaluate("'" & Format(.Range("K4"), "mmmm yy") & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = Format(.Range("k4"), "mmmm yy")
   .Range("A1:N31").Copy
   Sheets(Format(.Range("K4"), "mmmm yy")).Rows(1).Resize(30).Insert xlDown
   Sheets(Format(.Range("K4"), "mmmm yy")).Cells(1).PasteSpecial 12
   .Range("c8:i8") = Sheets(Format(.Range("K4"), "mmmm yy")).Range("c10:i10").Value
   .Range("k8:n8") = Sheets(Format(.Range("K4"), "mmmm yy")).Range("k10:n10").Value
   .ExportAsFixedFormat 0, "c:\temp\" & .Range("k4").Value
    With CreateObject("Outlook.Application").CreateItem(0)
      .To = ""
      .Subject = "Machinekamerrapport"
      .attachments.Add "c:\temp\" & Sheets("blad1").Range("k4").Value & ".pdf"
      .display '(voor directe versturen gebruik je) .send
    End With
 Kill "c:\temp\" & .Range("k4").Value & ".pdf"
  .Range("k9").Resize(, 4).ClearContents
  .Range("b12:n20,b22:n30").ClearContents
  .Protect "wachtwoord"
End With
End Sub
 
Laatst bewerkt:
Ik hoop dat het zo beter gaat.
De PDF wordt geopend, maar moet jezelf printen.
De code stopt pas na het sluiten van de PDF.

Code: 
Sub hsv()
Application.ScreenUpdating = False
With Sheets("blad1")
 If IsError(Evaluate("'" & Format(.Range("K4"), "mmmm yy") & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = Format(.Range("k4"), "mmmm yy")
   .ExportAsFixedFormat 0, "c:\temp\" & .Range("k4").Value, , , , , , -1
   Application.Wait DateAdd("s", 1, Now)
   .Range("A1:N30").Copy
   Sheets(Format(.Range("K4"), "mmmm yy")).Rows(1).Resize(30).Insert xlDown
   Sheets(Format(.Range("K4"), "mmmm yy")).Cells(1).PasteSpecial 12
   .Range("c8:i8") = Sheets(Format(.Range("K4"), "mmmm yy")).Range("c10:i10").Value
   .Range("k8:n8") = Sheets(Format(.Range("K4"), "mmmm yy")).Range("k10:n10").Value
   
    With CreateObject("Outlook.Application").CreateItem(0)
      .To = ""
      .Subject = "Machinekamerrapport"
      .attachments.Add "c:\temp\" & Sheets("blad1").Range("k4").Value & ".pdf"
      .display '(voor directe versturen gebruik je) .send
    End With
 Do
  On Error Resume Next
   Kill "c:\temp\" & .Range("k4").Value & ".pdf"
 Loop While Err.Number = 0
  .Range("k9").Resize(, 4).ClearContents
  .Range("c10").Resize(, 8).ClearContents
  .Range("b12:n20,b22:n30").ClearContents
End With
End Sub
 
dit werkt goed :thumb:
in 1x naar het afdrukscherm in niet mogelijk?

als dit niet mogelijk is wil je dan het openen van de pdf er weer uit willen halen? dan kunnen makkelijker printen vanaf de bijlage mail.
 
Laatst bewerkt:
ik heb zelf wat geprobeerd en het werkt :D ( ActiveSheet.PrintOut )
zou je alleen het openen van de pdf uit onderstaande code willen halen? ik kan niet ontcijferen waar dat staat :d

Code: 
Sub hsv()
ActiveSheet.PrintOut
Application.ScreenUpdating = False
With Sheets("blad1")
.Unprotect "wachtwoord"
 If IsError(Evaluate("'" & Format(.Range("K4"), "mmmm yy") & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = Format(.Range("k4"), "mmmm yy")
   .ExportAsFixedFormat 0, "c:\temp\" & .Range("k4").Value, , , , , , -1
   Application.Wait DateAdd("s", 1, Now)
   .Range("A1:N31").Copy
   Sheets(Format(.Range("K4"), "mmmm yy")).Rows(1).Resize(30).Insert xlDown
   Sheets(Format(.Range("K4"), "mmmm yy")).Cells(1).PasteSpecial 12
   .Range("c8:i8") = Sheets(Format(.Range("K4"), "mmmm yy")).Range("c10:i10").Value
   .Range("k8:n8") = Sheets(Format(.Range("K4"), "mmmm yy")).Range("k10:n10").Value
   
    With CreateObject("Outlook.Application").CreateItem(0)
      .To = ""
      .Subject = "Machinekamerrapport"
      .attachments.Add "c:\temp\" & Sheets("blad1").Range("k4").Value & ".pdf"
      .display '(voor directe versturen gebruik je) .send
    End With
 Do
  On Error Resume Next
   Kill "c:\temp\" & .Range("k4").Value & ".pdf"
 Loop While Err.Number = 0
  .Range("k9").Resize(, 4).ClearContents
  .Range("b12:n20,b22:n30").ClearContents
  .Protect "wachtwoord"
End With
End Sub
 
Ik dacht dat je de pdf wilde printen.

In mijn zoektocht ben ik een aantal codes tegengekomen maar die vond ik veel lang.
De kortere was ik mee aan het testen.

Maar goed:
Het printen van blad1:

Code: 
Sub hsv()
Application.ScreenUpdating = False
With Sheets("blad1")
.printout
.Unprotect "wachtwoord"

Verwijder de zes komma's en -1:
Code: 
.ExportAsFixedFormat 0, "c:\temp\" & .Range("k4").Value[COLOR=#ff0000], , , , , , -1[/COLOR]

Trouwens pdf rechtstreeks printen:
Code: 
progr = "C:\Program Files (x86)\Adobe\acrobat reader DC\Reader\AcroRd32.exe"
      sfile = "c:\users\gebruikersnaam\documents\test.pdf"
        Shell (progr & " /t " & sfile)
 
Laatst bewerkt:
ja sorry ik dacht eerst alleen aan de pdf maar "Blad1" is natuurlijk veel eenvoudiger om te printen.

Ik denk dat alles zo werkt zoals ik graag zou willen, anders meld ik me wel weer:rolleyes:

Bedankt.
 
We gebruiken het al een aantal maanden en het werkt perfect, ik zou alleen graag nog een paar kleine veranderingen willen als dat mogelijk is.

1.De werkbladen die per maand worden gemaakt, is het ook mogelijk dat elke nieuwe maand dus werkblad als 2e in de rij komt te staan?
dus "blad1" en dan de laatste maand. Blad 1, Juni 19, Mei 19, April 19, Maart 19, elke nieuwe maand vooraan.

2.als alles gekopieerd en verzonden is dat hij het bestand opslaat

3.zou graag een pop-up venster of iet willen waar in staat van "Gereed" of "Uitgevoerd" als alles klaar is verzonden en opgeslagen.

er zijn mensen die het voor elkaar krijgen om het niet opslaan of te snel weg klikken waardoor we soms gegevens missen.

Code: 
Sub hsv()
Application.ScreenUpdating = False
With Sheets("blad1")
.PrintOut From:=1, To:=1
.Unprotect "....."
 If IsError(Evaluate("'" & Format(.Range("K4"), "mmmm yy") & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = Format(.Range("k4"), "mmmm yy")
   .ExportAsFixedFormat 0, "c:\temp\" & .Range("k4").Value
   Application.Wait DateAdd("s", 1, Now)
   .Range("A1:N31").Copy
   Sheets(Format(.Range("K4"), "mmmm yy")).Rows(1).Resize(30).Insert xlDown
   Sheets(Format(.Range("K4"), "mmmm yy")).Cells(1).PasteSpecial 12
   .Range("c8:i8") = Sheets(Format(.Range("K4"), "mmmm yy")).Range("c10:i10").Value
   .Range("k8:n8") = Sheets(Format(.Range("K4"), "mmmm yy")).Range("k10:n10").Value
   
    With CreateObject("Outlook.Application").CreateItem(0)
      .To = "---@---.nl"
      .Subject = "Machinekamerrapport"
      .attachments.Add "c:\temp\" & Sheets("blad1").Range("k4").Value & ".pdf"
      .send
    End With
 Do
  On Error Resume Next
   Kill "c:\temp\" & .Range("k4").Value & ".pdf"
 Loop While Err.Number = 0
  .Range("k9").Resize(, 4).ClearContents
  .Range("b12:n20,b22:n30").ClearContents
  .Protect "......"
End With
End Sub
 
1.
Code: 
sheets(format(date, "mmmm yy")).move ,sheets(1)

2.
Code: 
thisworkbook.save

3.
Code: 
msgbox "Gereed"
 
Top,

wil je de codes er voor me tussen zetten?
heb het wel geprobeerd maar hij slaat niet op.

bedankt.
 
Laatst bewerkt:
1. Vergeet die coderegel en plaats onderstaande in thisworkbookmodule.
Code: 
Private Sub Workbook_NewSheet(ByVal Sh As Object)
 If IsError(Evaluate(Format(Date, "'mmmm yy") & "'!A1")) Then
     Sh.Name = Format(Date, "mmmm yy")
     Sh.Move , Sheets(1)
  Else
    Application.DisplayAlerts = False
    Sh.Delete
 End If
End Sub


2. komt tussen 'End With' en 'End Sub'.
3. kan je daar weer onder zetten.
 
Code 1 werkt niet in de thisworkbook module.
andere 2 werken wel goed:thumb:
 
Dat gaat pas volgende maand (juli) werken als jij een nieuw blad invoegt.
De naam wordt automatisch (juli 19) benoemd en komt direct op de tweede plaats.
Je blad juni moet je verwijderen of handmatig eenmalig verplaatsen.
 
We gebruiken het nu al een tijdje en werkt perfect.
Toch af en toe kopieert hij niet naar het werkblad van de maand, de pagina printen, versturen via mail, werkblad leeg maken en het bestand opslaan
alles doet hij maar toch kopieert hij af en toe niet. zou dit aan de laptop liggen of toch aan de code?
laptop moet soms wel even na denken als ik op de knop klik.:D
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan