VBA Exporteren bepaalde data naar nieuw workbook

[GerjanHM]

Hallo,

Wederom zou ik graag gebruik willen maken van jullie kennis.

Kort gezegd bepaalde data en bepaalde kolommen uit een tabel moeten worden gekopieerd naar een nieuwe werkbook
Vanuit een systeem krijg ik een dump naar excel. Dit wordt neergezet in een tabel. Graag zou ik bepaalde data door middel van een VBA willen exporteren naar een nieuwe werkboek. Welke rijen en kolommen moeten worden gekopieerd verandert constant. Door middel van sorteren(of slicer) kan een bepaalde selectie worden gemaakt. Alleen de zichtbare/gesorteerde data moet worden getransporteerd. Hierbij zou het ook mooi zijn als er een keuze is om alleen bepaalde kolommen te kopiëren.

Ik heb al een en ander geprobeerd. Wat wel lukt is het genereren van een nieuw bestand en het selecteren van bepaalde kolommen d.m.v. een userform. Het daadwerkelijk kopiëren van de data lukt niet. Dit moet voldoen aan twee voorwaarde, wat zichtbaar/gesorteerd is en de kolommen die geselecteerd zijn. Zie ook mijn voorbeeld


Weet iemand hier een oplossing voor?
Alvast bedankt voor de moeite!

Bekijk bijlage Probleem tabel.xlsm

P.S. Indien het niet mogelijk is, is een oplossing voor het kopiëren met alleen de keuze voor bepaalde kolommen (en dus zonder de selectie met het sorteren) wel mogelijk. Alle oplossingen zijn welkom

 

[edmoor]

Ik heb 1 kolom aan je code toegevoegd, de rest kan je dan vast zelf wel

Private Sub CommandButton1_Click()
    Dim sBook As Workbook
    
    Set sBook = ActiveWorkbook
    
    'genereer nieuwe workbook
    Workbooks.Add
    With ActiveWorkbook.Sheets("Blad1")
        .Cells(2, 2).Value = "Uitdraai bronbestand SAZ"
        
        'Kopieer data kolom 1
        If CheckBox1 Then sBook.Sheets("Blad1").Columns("C").Copy Destination:=.Columns("C")
    End With

    Unload Me
End Sub

N.B:
De .Value = True mag je weg laten bij een CheckBox.
Je kan controleren wat de waarde is met If CheckBox1 of If Not CheckBox1.
Het is een Boolean.

 

[Leotaxi]

Code in userform aangepast zodat geselecteerde kolommen, gefilterd
worden gekopiëerd naar blad2.

best het deel om in nieuw workbook op te slaan, na het kopiëren te plaatsen.

mvg
Leo

 

[GerjanHM]

Leotaxi en Edmoor,

Bedankt voor jullie reactie. Beiden werken op hun eigen manier prima! De één kopieert precies de goede (gesorteerde) data, maar naar een andere sheet. De ander kopieert maar een nieuwe werkboek maar de gehele kolom (niet de gesorteerde data). Simpel gezegd zou een combi van jullie oplossingen ideaal zij. Daarom al een tijdje aan het proberen een en ander te combineren. Hoewel het me in eerste instantie simpel leek lukt het me toch niet.

Code met oplossing Leotaxi in oplossing edmoor:

Sub Leataxi_In_Edmoor()

Application.ScreenUpdating = False
x = 1

    Dim sBook As Workbook
    Set sBook = ActiveWorkbook
    
    'genereer nieuwe workbook
    Workbooks.Add
    With ActiveWorkbook.Sheets("Blad1")
        .Cells(2, 2).Value = "Uitdraai bronbestand SAZ"
        
        'Kopieer data kolom 1
        If CheckBox1 Then sBook.Sheets("Blad1").Range("Tabel1[[#All],[A]]").Copy Destination:=.Cells(3, x)
        
    End With
           
Application.CutCopyMode = False
Application.ScreenUpdating = True
Unload Me
End Sub

Hierbij wordt er wel een nieuwe werkbook gegenereerd maar niet de geselecteerde data (kopieerde de hele kolom)



Code met oplossing edmoor in oplossing Leotaxi:

Sub Edmoor_In_Leataxi()

Application.ScreenUpdating = False
x = 1

    Dim sBook As Workbook
    Set sBook = ActiveWorkbook
    
    'genereer nieuwe workbook
    Workbooks.Add
    With ActiveWorkbook.Sheets("Blad1")
        .Cells(2, 2).Value = "Uitdraai bronbestand SAZ"
        
        'Kopieer data kolom 1
        If Me.CheckBox1.Value = True Then
            sBook.Sheets("Blad1").Range("Tabel1[[#All],[A]]").Select
            With Selection
                .Copy Destination:=.Cells(3, x)
            End With
        x = x + 1
        End If
    End With
                  
Application.CutCopyMode = False
Application.ScreenUpdating = True
Unload Me
End Sub

Hier onstaat er echter een oprobleem met "sBook"


Weet een van jullie zo een oplossing om het te combineren?
alvast bedankt:thumb:

 

[sylvester-ponte]

probeer deze eens: leo + ed

'Private Sub CommandButton1_Click()

    Application.ScreenUpdating = False
    Dim sBook As Workbook
    Set sBook = ActiveWorkbook

    'genereer nieuwe workbook
    Workbooks.Add
    With ActiveWorkbook.Sheets("Blad1")
        x = 1
        'Kopieer data kolom 1
        If Me.CheckBox1.Value = True Then
            sBook.Sheets("Blad1").Range("Tabel1[[#All],[A]]").Copy Destination:=.Cells(3, x)
            x = x + 1
        End If
        'Kopieer data kolom 2
        If Me.CheckBox2.Value = True Then
            sBook.Sheets("Blad1").Range("Tabel1[[#All],[B]]").Copy Destination:=.Cells(3, x)
            x = x + 1
        End If

        'Kopieer data kolom 3
        If Me.CheckBox3.Value = True Then
            sBook.Sheets("Blad1").Range("Tabel1[[#All],[C]]").Copy Destination:=.Cells(3, x)
            x = x + 1
        End If
        'Kopieer data kolom 4
        If Me.CheckBox4.Value = True Then
            sBook.Sheets("Blad1").Range("Tabel1[[#All],[D]]").Copy Destination:=.Cells(3, x)
            x = x + 1
        End If
        'Kopieer data kolom 5
        If Me.CheckBox5.Value = True Then
            sBook.Sheets("Blad1").Range("Tabel1[[#All],[E]]").Copy Destination:=.Cells(3, x)
            x = x + 1
        End If
        'Kopieer data kolom 6
        If Me.CheckBox6.Value = True Then
            sBook.Sheets("Blad1").Range("Tabel1[[#All],[F]]").Copy Destination:=.Cells(3, x)
            x = x + 1
        End If
        'Kopieer data kolom 7
        If Me.CheckBox7.Value = True Then
            sBook.Sheets("Blad1").Range("Tabel1[[#All],[G]]").Copy Destination:=.Cells(3, x)
            x = x + 1
        End If
        'Kopieer data kolom 8
        If Me.CheckBox8.Value = True Then
            Range("Tabel1[[#All],[G]]").Select
            With Selection
                .Copy Destination:=.Cells(3, x)
            End With
            x = x + 1
        End If
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End With


    Unload Me
End Sub

 

[Leotaxi]

kom zelf niet tot een oplossing tijdens koiëren, wel blad naar nieuw workbook
na het kopiëren.

@ Sylvester
had ik ook getest, maar brengt volledige kolom en niet gefilterde kolom over.


mvg
Leo

 

[sylvester-ponte]

Deze doet het zonder extra blad:

 

[GerjanHM]

sylvester-ponte en Leotaxi bedankt voor jullie oplossingen.
Helemaal top.

P.s. eerst kopieren naar sheet en dan naar nieuwe werkbook, why dindn't i think of that