Rijen van tabel overzetten in een nieuw aangemaakt bestand.

[Roeland035]

Beste Forumleden,

Ik heb een tabel waarin het aantal regels kan variëren van één tot 5000.
Dit tabel bestaat uit 5 kolommen (A t/m E)

Ik zou graag willen dat zodra er op een knop gedrukt wordt op het tabblad zelf, dat dit tabel overgezet wordt naar een nieuw aangemaakt bestand.
Dit is in principe niet zo moeilijk en ik heb daar al een code voor, maar.....

De regels waarvan kolommen C/D/E de waarde 0 hebben moeten NIET overgezet worden naar het nieuwe bestand.

Onderstaand heb ik de code bijgevoegd die ik gebruik om het gehele tabel over te zetten, maar dan nog niet met mijn gestelde criteria.

Sub ExportCSV()
Dim MyPath As String
Dim MyFileName As String

MyFileName = Sheets("Input Leverancier info").Range("A3").Value & "_" & Format(Date, "DD-MM-YYYY") & ".(periode_" & Sheets("Exporteer naar CSV").Range("F1").Value & ")"
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
    
        Set Newbook = Workbooks.Add
        Workbooks("LogicTrade - Besteladvies.xlsm").Worksheets("Exporteer naar CSV").Range("A2:E5000").Copy
        Newbook.Worksheets("Blad1").Range("A1").PasteSpecial Paste:=xlPasteValues
        Newbook.Worksheets("Blad1").Columns("A:E").AutoFit
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = ""
        If .Show <> -1 Then GoTo NextCode
        MyPath = .SelectedItems(1) & "\"
    End With
NextCode:
    Application.DisplayAlerts = False
    If MyPath = "" Then GoTo ResetSettings
    Newbook.SaveAs filename:=MyPath & MyFileName, FileFormat:=56, Local:=True

ResetSettings:
  'Reset Macro Optimization Settings
    Application.DisplayAlerts = False
    Newbook.Close
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

Opmerking*
Zodra één van die drie kolommen 0 is, dan is de rest automatisch ook 0.

Ik hoop dat één van jullie mij hier mee kan helpen!

Bijgevoegd een voorbeeld bestand.
Bekijk bijlage Voorbeeld.xlsx

 

[Roeland035]

In principe kan ik het zelf ook wel, maar dan zou ik op mijn huidige werkblad een tabel ervoor maken en dan die volledig over kopiëren. Het lijkt mij alleen wel omslachtig om dat zo te doen, of valt dat wel mee?

 

[snb]

Een tabel is in het Nederlands niet onzijdig: de tabel.

 

[mastermindzh]

@snb, Dit forum is niet bedoeld voor een grammaticales en ik wil bij deze dus ook vragen dat achterwege te laten. Als u reageert dan graag inhoudelijk op de vraag.

 

[Roeland035]

Ben er zelf al uit gekomen door middel van een tabel op een verborgen sheet.

Sub Opgenomen_Artikelen()
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    Dim MyPath As String
    Dim MyFileName As String
    Dim mySheet As Worksheet
    
    Worksheets("Temporary").Visible = True
    
    Worksheets("Exporteer naar CSV").Range("A4:E5000").Copy _
        Destination:=Worksheets("Temporary").Range("A4")

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False

    End With

    With Sheets("Temporary")
        .Select

        ViewMode = ActiveWindow.View
        ActiveWindow.View = xlNormalView

        .DisplayPageBreaks = False

        Firstrow = .UsedRange.Cells(1).Row
        Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

        For Lrow = Lastrow To Firstrow Step -1
            With .Cells(Lrow, "C")
                If Not IsError(.Value) Then
                    If .Value = "0" Then .EntireRow.Delete
                End If
            End With
        Next Lrow
    End With

    ActiveWindow.View = ViewMode
    With Application
        .ScreenUpdating = False
        .Calculation = CalcMode
    End With
    
MyFileName = Sheets("Input Leverancier info").Range("A3").Value & "_" & "opgenomen artikelen"
    If Not Right(MyFileName, 4) = ".xls" Then MyFileName = MyFileName & ".xls"
    
        Set Newbook = Workbooks.Add
        Workbooks("LogicTrade - Besteladvies.xlsm").Worksheets("Temporary").Range("A1:E5000").Copy
        Newbook.Worksheets("Blad1").Range("A1").PasteSpecial (xlPasteAll)
        Newbook.Worksheets("Blad1").Columns("A:E").AutoFit
        Newbook.Worksheets("Blad1").Range("A1").Select
    
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = ""
    If .Show <> -1 Then GoTo NextCode
    MyPath = .SelectedItems(1) & "\"
End With
NextCode:
    If MyPath = "" Then GoTo ResetSettings
    Newbook.SaveAs filename:=MyPath & MyFileName & ".xls", FileFormat:=56, Local:=True

ResetSettings:
  'Reset Macro Optimization Settings
    Application.DisplayAlerts = False
    Newbook.Close
        Sheets("Temporary").Select
        Range("A4:L5000").Select
        Selection.ClearContents
        Range("A1").Select
        Sheets("Exporteer naar CSV").Select
        Range("A1").Select
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Worksheets("Temporary").Visible = False
End Sub

Omslachtig, maar het werkt.

 

[mastermindzh]

Helemaal mooi Roeland035 !
Dan kan de vraag op opgelost

Prettige dag nog verder. :thumb:

 

[Roeland035]