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

Wijziging VB code (VenA)

Status
Niet open voor verdere reacties.
J

jarre2

Gebruiker
Lid geworden
9 nov 2011
Berichten
43
Goede middag,

In het verleden ben ik door dit forum geholpen (Jolivanes en VenA) met een vb code, om uit blad ‘klanten’ een dagelijks afsprakenlijstje te maken. Deze code wordt nog elke dag gebruikt.
De werking:
• Door in kolom A van blad ‘klanten’ een willekeurig aantal ‘s’ te plaatsen, zal de inhoud van de naast gelegen kolommen getransporteerd worden naar blad ‘afspraken’ gesorteerd op dag en tijd;

• Een wijziging in het bestand maakt het echter wenselijk om niet alle opeenvolgende kolommen naar ‘afspraken’ te transporteren.
Het zouden alleen de kolommen 2 t/m 8 - 10 t/m 14 en 18 t/m 21 moeten zijn.

De vraag: zou het te realiseren zijn om de bestaande code zo aan te passen dat alleen de gewenste kolommen worden overgezet?

Vr. gr.
Jarre
 

Bijlagen

  • Kolommen selektie.xlsm
    31,7 KB · Weergaven: 71
Kwestie van de kolommen die je niet wilt meenemen verbergen. Desnoods met de macro, en dan later weer zichtbaar maken.
 
En als je het in de macro wilt aanpassen, krijg je zoiets:
Code: 
    With ActiveSheet
        Range("I:I,O:Q").EntireColumn.Hidden = True
        .AutoFilterMode = False
        .Range("A1:A" & lr).AutoFilter field:=1, Criteria1:="s"
        .Range("B2:Z" & lr).SpecialCells(12).Copy Sheets("Afspraken").Range("A4")
        .AutoFilterMode = False
        Range("I:I,O:Q").EntireColumn.Hidden = False
    End With
 
Wijziging VB code

@OctaFish,

Dank voor het meedenken, helaas een foutcode 1004

Jarre
 
Zo werkt hij bij mij wel.
Code: 
Sub Maybe()
 Dim lr As Long
 Dim Ants As Integer
 Ants = WorksheetFunction.CountIf(Sheets("Klanten").Range("A:A"), "s")
 If Ants < 1 Then
 MsgBox "Er zijn geen selecties gevonden"
 Exit Sub
 End If 
 lr = Cells(Rows.Count, 1).End(xlUp).Row
 Application.ScreenUpdating = False
 Sheets("Afspraken").Range("A2", Sheets("Afspraken").Range("A" & Rows.Count).End(xlDown).Resize(, 26)).ClearContents
 With ActiveSheet
 .AutoFilterMode = False
 .Range("A1:A" & lr).AutoFilter field:=1, Criteria1:="s"
 .Range("B2:Z" & lr).SpecialCells(12).Copy Sheets("Afspraken").Range("A4")
 .AutoFilterMode = False
 End With 
    With ActiveSheet
        Range("I:I,O:Q").EntireColumn.Hidden = True
        .AutoFilterMode = False
        .Range("A1:A" & lr).AutoFilter field:=1, Criteria1:="s"
        .Range("B2:Z" & lr).SpecialCells(12).Copy Sheets("Afspraken").Range("A4")
        .AutoFilterMode = False
        Range("I:I,O:Q").EntireColumn.Hidden = False  
 Sheets("Afspraken").Activate
 With .PageSetup
 .FitToPagesWide = 1
 .FitToPagesTall = 1
 End With
 '.PrintOut Copies:=1, Preview:=False
 End With
 Application.ScreenUpdating = True
 End Sub
 
Laatst bewerkt:
@ExcelAmateur,

Hartelijk dank, het werkt goed.
Soms zijn er maar vijf afspraken op een dag. Een aanvullende vraag: zou het mogelijk zijn om onder elke geprinte afspraak een horizontaal lijntje te printen? Met bovenstaande oplossing ben ik al blij, als een dun lijntje printen niet mogelijk is, dan is dat jammer maar mee te leven.

Vr. gr.
Jarre
 
Jarre,

Zo goed ben ik niet in VBA, ik heb alleen gezorgd dat het stukje code van OctaFish op de goede plek kwam.
Misschien kan hij je hier mee helpen.
 
@ OctaFish en ExcelAmatuur,

Hartelijk dank voor de geboden oplossingen.

Vr. gr.

Jarre
 
Zie #6

Misschien weet een andere deskundige een oplossing om onder elke geprinte regel een horizon lijntje te printen.

Jarre
 
Misschien zo:
Code: 
Sub Maybe()
    Dim lr As Long
    Dim Ants As Integer
    Dim Sh
    
    Ants = WorksheetFunction.CountIf(Sheets("Klanten").Range("A:A"), "s")
    If Ants < 1 Then MsgBox "Er zijn geen selecties gevonden": Exit Sub
 
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    Application.ScreenUpdating = False
    Set Sh = Sheets("Afspraken")
    Sh.Range("A2", Sh.Range("A" & Rows.Count).End(xlDown).Resize(, 26)).ClearContents
    With ActiveSheet
        Range("I:I,O:Q").EntireColumn.Hidden = True
        .AutoFilterMode = False
        .Range("A1:A" & lr).AutoFilter field:=1, Criteria1:="s"
        .Range("B2:Z" & lr).SpecialCells(12).Copy Sheets("Afspraken").Range("A4")
        .AutoFilterMode = False
        Range("I:I,O:Q").EntireColumn.Hidden = False
        Sh.Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
        With Sh.Cells(4, 1).CurrentRegion
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
                .LineStyle = xlContinuous
                .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlThin
            End With
        End With

    End With
    Sh.Activate
    With Sh
        .Cells.EntireColumn.AutoFit
        .Range("A1").CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2"), Order2:=xlAscending, Header:=xlYes
        With .PageSetup
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
        '.PrintOut Copies:=1, Preview:=False
    End With
    Application.ScreenUpdating = True
 End Sub
 
@Timshel

Dit is exact wat ik voor ogen had. Fantaschtish dat dit gerealiseerd is. Respect voor diegene, die hun kennis willen delen.

Hartelijk dank, ook aan de andere helpers.

Vr. gr.
Jarre
 
Of:

Code: 
Sub M_snb()
  Sheets("afspraken").Cells.ClearContents

  With Sheets("klanten").Cells(1).Resize(, 21).CurrentRegion
    .AutoFilter 1, "s"
    .Copy Sheets("afspraken").Cells(1)
    .AutoFilter
  End With
    
  With Sheets("afspraken")
    .Cells.Borders.LineStyle = xlNone
    .Range("A1,I1,O1:Q1").EntireColumn.Delete
    With .Cells(1).CurrentRegion.Offset(1).Borders(12)
      .LineStyle = 1
      .Weight = 2
    End With
    .Columns.AutoFit
    .Cells(1).CurrentRegion.Sort .Cells(1, 2), , .Cells(1, 3), , , , , 1
    With .PageSetup
      .FitToPagesWide = 1
      .FitToPagesTall = 1
    End With
    '.PrintOut 1, False
  End With
End Sub
 
Laatst bewerkt:
@snd

Een buiging voor het inkorten van het script. Op dit forum heb ik een keer gelezen 'is dit vb van snd van een andere planeet?'. De moeite waard om dit script proberen te doorgronden en hieruit lering uit te trekken.

Dank voor de moeite.

Jarre
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan