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

Kopiëren van een gefilterde tabel naar een ander tabblad met afwijkende kolombreede's

Status
Niet open voor verdere reacties.
M

Mpvandrie

Gebruiker
Lid geworden
22 sep 2007
Berichten
6
Beste Allemaal,

In het meegestuurde voorbeeld heb ik op werkblad MATERIAAL B18:E104 en op GEGEVENS B4:K88 en Q9:AA18 de velden IN GEEL aangegeven die ik in OFFERTE wil weergeven.

Let wel, ik wil alleen de gegevens in de tabel opnemen waarvan de waarde <>0 voor de kolommen B in tab materiaal en gegevens en de kolom Q in gegevens.
Ik heb hiervoor een filter geplaatst op rij 3.

Ik probeer om via Macro Opname een aantal gegevenstabellen in een offertesheet op te nemen.
Door het toepassen van Macro Opname werken de verwijzingen niet correct en wordt er verkeerd gefilterd. (filter = toestand tijdens opname.)
Het lukt echter wel om de gegevenstabel te kopiëren als afbeelding en vervolgens in de offerte te kopiëren.

Ik loop tegen het volgende op:

1 : De kolombreedtes van de offertesheet staan vast en de 3 verschillende gegevenstabellen hebben allemaal afwijkende kolombreedtes.
2 : De Gegevenstabellen zijn voorzien van filters om de artikelen of ALLEEN GEGEVENS >O weer te geven. Het aantal regels per tabel kan voor elke offerte anders zijn.
3 : Niet alle kolommen van de range Q9:AA18 moeten worden gekopieerd naar OFFERTE, alleen de in dit voorbeeld zichtbare.


Bekijk bijlage CALCULATIE_OFFERTE_help_mij.xlsm


Na aanpassen van de opname van de macro heb ik de oplossing zelf gevonden.

toegepaste macro :

Sub Offerte_Genereren()
'
' Offerte_Genereren Macro
'
' Sneltoets: Ctrl+o
'
Sheets("PRIJZEN MATERIAAL").Select
ActiveSheet.Range("$B$23:$B$430").AutoFilter Field:=1, Criteria1:="<>0", _
Operator:=xlAnd
Range("B24:E430").Select
Range("E430").Activate
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Sheets("OFFERTE").Select
Range("L4").Select
ActiveSheet.Paste
Sheets("TOTAAL TAB").Select
ActiveSheet.Range("$B$3:$Q$88").AutoFilter Field:=16, Criteria1:="<>0", _
Operator:=xlAnd
Range("Q9:AA19").Select
Range("AA19").Activate
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Sheets("OFFERTE").Select
Range("L124").Select
ActiveSheet.Paste
Sheets("TOTAAL TAB").Select
ActiveSheet.Range("$B$3:$Q$88").AutoFilter Field:=16
ActiveSheet.Range("$B$3:$Q$88").AutoFilter Field:=1, Criteria1:="<>0", _
Operator:=xlAnd
Range("B4:K89").Select
Range("K89").Activate
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Sheets("OFFERTE").Select
Range("L64").Select
ActiveSheet.Paste
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
End Sub
 
Laatst bewerkt:
Nu nog een beetje structuur in het geheel aanbrengen.

Code: 
Sub VenA()
  With Sheets("MATERIAAL").Range("$B$17:$E$105")
    .AutoFilter 1, "<>0"
    .Offset(1).CopyPicture
    Sheets("OFFERTE").Range("L4").PasteSpecial
    .AutoFilter
  End With
  With Sheets("GEGEVENS")
    With .Range("$B$3:$K$88")
      .AutoFilter 1, "<>0"
      .Offset(1).CopyPicture
      Sheets("OFFERTE").Range("L64").PasteSpecial
      .AutoFilter
    End With
    With .Range("Q8:AA20")
      .AutoFilter 1, "<>0"
      .Offset(1).CopyPicture
      Sheets("OFFERTE").Range("L124").PasteSpecial
      .AutoFilter
    End With
  End With
End Sub
 
Structuur

Ik zie het... al ben ik allerminst een programmeur. (buiten een klein beetje ouderwets HTML geneuzel)
Ik ben zelf druk bezig geweest om de macro uit te breiden...
De offerte is ook uitgebreider geworden (waardoor nu alle bereiken zijn veranderd)

In de macro heb ik toegevoegd :

1) zorgen dat m'n scherm niet meer flikkert,
2) alle beveiligde Worksheets "unlocken"
3) Tabellen filteren voor juiste weergave
4) Tabellen met Kopiëren (als afbeelding - als op afdruk) naar offerte formulier zetten
5) Offerte afdrukken als PDF
6) Afbeeldingen uit de offerte wghalen
7) Worksheets weer beveiligen met password

Ik zal mijn code proberen aan te passen zodat hij er net zo netjes uitziet als die van jou.

Hier onderaan de oorspronkelijke versie, jou versie, en mijn laatste nieuwe (nog niet gestroomlijnde) versie.

Dank voor jou input, ik hoop er van te leren !

Bekijk bijlage Structuur.xlsm
 
Die laatste versie is zeer zeker nog niet gestroomlijnd:d

Gebruik geen Select Selection Activate als het niet nodig is.
Een stukje uit jouw code
Code: 
Sub geenidee()
  Sheets("AANTEKENINGEN").Select
  Range("D5:D10").Select
  Range("D10").Activate
  Selection.Copy
  Sheets("OFFERTE").Select
  Range("B210").Select
  ActiveSheet.Paste
End Sub

zou ik zo schrijven
Code: 
Sub VenA()
  Sheets("AANTEKENINGEN").Range("D5:D10").Copy Sheets("OFFERTE").Range("B210")
End Sub

of als het alleen om de waarden gaat
Code: 
Sub VenA()
  Sheets("OFFERTE").Range("B210").Resize(6) = Sheets("AANTEKENINGEN").Range("D5:D10").Value
End Sub

Geen scherm die gaat 'flikkeren'
 
Laatst bewerkt:
Plaatjes Kopiëren

deze aanpassing werkt : Sheets("AANTEKENINGEN").Range("D5:D10").Copy Sheets("OFFERTE").Range("B210")

Ik zet hieronder eventuele toegepaste filters uit (deze kunnen worden gebruikt door gebruiker en anders werkt mijn selectie die ik wil maken niet), dan kopieer ik een plaatje naar offerte (=xl picture). Vraagje : kan dit net zo compact worden als hierboven?

Sheets("PRIJZEN MATERIAAL").Select
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ActiveSheet.Range("$A$23:$M$430").AutoFilter Field:=2, Criteria1:="<>0", _
Operator:=xlAnd
Range("B24:E430").Select
Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Sheets("OFFERTE").Select
Range("L4").Select
ActiveSheet.Paste
 
Gebruik svp codetags voor de leesbaarheid. Klik even op de eerste link in de handtekening van @SjonR over hoe je codetags kan plaatsen. Wat de vraag betreft zie #4.
 
Gestroomlijnde code

Wie kan mij helpen deze code te stroomlijnen ?


Code: 
Private Sub Offerte()
'
' Offerte Macro
'
' Sneltoets: Ctrl+o
'
Application.ScreenUpdating = False

Dim ins As Integer
For ins = 1 To Worksheets.Count
Sheets(ins).Unprotect "xxx"
Next
Sheets("UITGANGSPUNTEN").Range("G7:G12").Copy Sheets("OFFERTE").Range("B210")
    Sheets("PRIJZEN MATERIAAL").Select
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    ActiveSheet.Range("$A$23:$M$430").AutoFilter Field:=2, Criteria1:="<>0", _
        Operator:=xlAnd
    Range("B24:E430").Select
    Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
        Sheets("OFFERTE").Select
        Range("B244").Select
        ActiveSheet.Paste
    Sheets("UITGANGSPUNTEN").Select
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    ActiveSheet.Range("$C$12:$C$50").AutoFilter Field:=1, Criteria1:="<>", _
        Operator:=xlAnd
    Range("C12:E50").Select
    Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
        Sheets("OFFERTE").Select
        Range("B64").Select
        ActiveSheet.Paste
    Sheets("TOTAAL TAB").Select
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    ActiveSheet.Range("$B$3:$Q$254").AutoFilter Field:=16, Criteria1:="<>0", Operator:=xlAnd
    Range("Q9:AA30").Select
    Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
        Sheets("OFFERTE").Select
        Range("B304").Select
        ActiveSheet.Paste
    Sheets("TOTAAL TAB").Select
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    ActiveSheet.Unprotect Password:="mpvd66"
    ActiveSheet.Range("$B$3:$Q$254").AutoFilter Field:=16
    ActiveSheet.Range("$B$3:$Q$254").AutoFilter Field:=1, Criteria1:="<>0", _
        Operator:=xlAnd
    Range("B4:K254").Select
    Range("K254").Activate
    Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
        Sheets("OFFERTE").Select
        Range("B327").Select
        ActiveSheet.Paste
        ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False

Dim sjeep As Shape, reensj As Range
Set reensj = Sheets("OFFERTE").Range("A1:I600")
    For Each sjeep In ActiveSheet.Shapes
        If sjeep.Type = msoPicture Then
            If Not Intersect(Range(sjeep.TopLeftCell, sjeep.BottomRightCell), reensj) Is Nothing Then
               sjeep.Delete
            End If
        End If
    Next sjeep

Application.ScreenUpdating = True

Dim uit As Integer
For uit = 1 To Worksheets.Count
Sheets(uit).Protect "xxx", AllowFiltering:=True
Next
End Sub
 
Hoe kom je toch steeds aan codes die een ander mag stroomlijnen.
De vorige suggesties beantwoorden lijkt me beter op z'n plaats wil je geholpen worden.
 
Poging tot stroomlijning

Beste Harry,

Natuurlijk heb jij gelijk, ik heb alleen nog wat extra futures toegepast. Hieronder de macro die ik heb ontdaan van select. selection en dergelijke.

Elke verdere poging tot vereenvoudiging levert bij mij foutmeldingen.

Code: 
Private Sub Offerte()
'
' Offerte Macro
'
Application.ScreenUpdating = False

Dim ins As Integer
For ins = 1 To Worksheets.Count
Sheets(ins).Unprotect "xxx"
Next

Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.FilterMode Then ws.ShowAllData
Next

Sheets("UITGANGSPUNTEN").Range("G7:G12").Copy Sheets("OFFERTE").Range("B210")
Sheets("PRIJZEN MATERIAAL").Select
    ActiveSheet.Range("$A$23:$M$433").AutoFilter Field:=2, Criteria1:="<>0", Operator:=xlAnd
    Range("B24:E433").CopyPicture Appearance:=xlPrinter, Format:=xlPicture
        Sheets("OFFERTE").Select
        Range("B244").Select
        ActiveSheet.Paste
Sheets("UITGANGSPUNTEN").Select
    ActiveSheet.Range("$C$12:$C$49").AutoFilter Field:=1, Criteria1:="<>", Operator:=xlAnd
    Range("C12:E49").CopyPicture Appearance:=xlPrinter, Format:=xlPicture
        Sheets("OFFERTE").Select
        Range("B64").Select
        ActiveSheet.Paste
Sheets("TOTAAL TAB").Select
    ActiveSheet.Range("$B$4:$Q$74").AutoFilter Field:=16, Criteria1:="<>0", Operator:=xlAnd
    Range("Q9:AB17").CopyPicture Appearance:=xlPrinter, Format:=xlPicture
        Sheets("OFFERTE").Select
        Range("B292").Select
        ActiveSheet.Paste
Sheets("TOTAAL TAB").Select
    ActiveSheet.Range("$B$4:$Q$74").AutoFilter Field:=1, Criteria1:="<>0", Operator:=xlAnd
    Range("B4:L74").CopyPicture Appearance:=xlPrinter, Format:=xlPicture
        Sheets("OFFERTE").Select
        Range("L74").Select
        ActiveSheet.Paste
Sheets("TOTAAL TAB").Select
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData

Dim c As Range
Dim i As Integer
Dim rng As Range
Set rng = ActiveSheet.AutoFilter.Range.Rows(1)
i = 1

For Each c In rng.Cells
  Select Case i
    Case 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15
      c.AutoFilter Field:=i, _
        Visibledropdown:=False
    Case Else
      c.AutoFilter Field:=i, _
        Visibledropdown:=True
  End Select
  i = i + 1
Next
    Sheets("OFFERTE").Select
        Range("B304").Select
    ActiveSheet.Paste
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

Dim sjeep As Shape, reensj As Range
Set reensj = Sheets("OFFERTE").Range("A1:I360")
    For Each sjeep In ActiveSheet.Shapes
        If sjeep.Type = msoPicture Then
            If Not Intersect(Range(sjeep.TopLeftCell, sjeep.BottomRightCell), reensj) Is Nothing Then
               sjeep.Delete
            End If
        End If
    Next sjeep

Dim wt As Worksheet
    For Each wt In ActiveWorkbook.Worksheets
    If wt.FilterMode Then wt.ShowAllData
Next

Dim uit As Integer
    For uit = 1 To Worksheets.Count
    Sheets(uit).Protect "xxxx", AllowFiltering:=True
Next

Application.ScreenUpdating = True

End Sub
 
Even snel gekeken.

De select en activesheet eruit en aan elkaar vast plakken.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan