Alleen de test kopieeren en opslaan?

[kaan]

Beste,

Ik heb een Bestand die ik als wachtrapport gebruik, deze gaan ik naar diverse mensen per mail verzenden.

Het probleem is dat deze bestand niet geroot mag zijn qua mb’s. Hij moet zo klein mogelijk zijn zo dat het in mail box niet te veel ruimte in beslag neemt.

Ik zelf ben er al een tijdje mee bezig maar kom niet uit en verzoek je advies, er zal toch wel een maneer zijn om deze op een simpele maneer in elkaar te zetten?

Met gebruik van macro’s moet het toch mogelijk zijn om van een Excel bestand alleen de tekst te kopiëren en verder niets?



Ik ga zo direct een voor beeld file uploden.

Alvast bedankt voor je idee en de tijd die je voor mij heb beteed.

 

[SillyMelody]

Bedoel je hier dat het bestand te groot is om via de mail te versturen ?
In dat geval kan je het inpakken in meerdere parts met bijvoorbeeld WinRar en deze parts versturen.
Ook via Yousendit is dan een handige oplossing

 

[Wigi]

Bedoel je hier dat het bestand te groot is om via de mail te versturen ?
In dat geval kan je het inpakken in meerdere parts met bijvoorbeeld WinRar en deze parts versturen.
Ook via Yousendit is dan een handige oplossing

Klopt, maar beter voorkomen dan genezen.

Je moet er eerst voor zorgen dat het bestand goed gemaakt is en geen overtollige of redundante dingen bevat. Onnodige opmaak, formules die beter kunnen, andere werkwijzen, ...

Wigi

 

[kaan]

Heren,

Dank voor je snelle reactie, WIGI begrijpt wat ik bedoel.

Het gaat niet om of het te geroot is om hem te verzenden maar dat het zo klein mogelijk is.

Ik wil een bestand in elkaar zetten met macro’s en alle toeters en bellen als ik deze dagelijks ga verzenden hebben mensen die ik deze bestand verzend een onnodig te
Eigenlijk hebben zij enkel de tekst nodig en verder niets.

Zodra ik op mijn werk ben ga ik een voorbeeld bestand uploaden.

Dank.

 

[Wigi]

Bestudeer deze net geschreven code eens:

Sub KopieerAlsWaarden()
    
'deze procedure kopieert de tabbladen in het huidige bestand naar een bestand,
'en plakt ze als waarden
'VBA code wordt niet overgenomen
'nieuw bestand wordt opgeslagen


'Wim Gielis
'08 06 2007
'wimmekegielis@hotmail.com

    
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim i As Integer
    Dim j As Integer
    
    Application.ScreenUpdating = False
    
    Set wbSource = ThisWorkbook
    
    i = 0
    
    Set wbTarget = Workbooks.Add
    With wbTarget
    
        'copying the values
        For Each wsSource In wbSource.Sheets
            If WorksheetFunction.CountA(wsSource.Cells) > 0 Then
                i = i + 1
                
                If i <= Application.SheetsInNewWorkbook Then
                    Set wsTarget = .Sheets(i)
                Else
                    Set wsTarget = Sheets.Add(After:=.Sheets(.Sheets.Count))
                End If
                
                wsSource.UsedRange.Copy
                wsTarget.Cells(1).PasteSpecial xlValues
                
                If SheetExists(.Name, wsSource.Name) = True Then .Sheets(wsSource.Name).Name = Int(Timer)
                wsTarget.Name = wsSource.Name
            End If
        Next
        
        'delete unneeded sheets
        For j = i + 1 To Application.SheetsInNewWorkbook
            Application.DisplayAlerts = False
            .Sheets(j).Delete
            Application.DisplayAlerts = True
        Next

        .SaveAs "C:\Waarden"
        .Close
    End With
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    MsgBox "Klaar!", vbInformation
End Sub

Function SheetExists(wbName As String, shName As String) As Boolean

'TRUE if the sheet with shName as name exists in the workbook named wbName (needs to be opened)
    
    On Error GoTo here
    If Len(Workbooks(wbName).Sheets(shName).Name) > 0 Then SheetExists = True
here:
End Function

Wigi

 

[Wigi]

Verbeterde versie van de code:

Sub KopieerAlsWaarden()
    
'deze procedure kopieert de tabbladen in het huidige bestand naar een bestand,
'en plakt ze als waarden
'VBA code wordt niet overgenomen
'nieuw bestand wordt opgeslagen


'Wim Gielis
'08 06 2007
'wimmekegielis@hotmail.com

    
    Dim wbSource As Workbook
    Dim wbTarget As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim i As Integer
    Dim j As Integer
    Dim sNewNameWs As String
    Dim sFileSaveName As Variant
    
    Application.ScreenUpdating = False
    
    Set wbSource = ThisWorkbook
    
    i = 0
    
    Set wbTarget = Workbooks.Add
    With wbTarget
    
        'copying the values
        For Each wsSource In wbSource.Sheets
            If WorksheetFunction.CountA(wsSource.Cells) > 0 Then
                i = i + 1
                
                If i <= Application.SheetsInNewWorkbook Then
                    Set wsTarget = .Sheets(i)
                Else
                    Set wsTarget = Sheets.Add(After:=.Sheets(.Sheets.Count))
                End If
                
                wsSource.UsedRange.Copy
                With wsTarget
                    .Cells(1).PasteSpecial xlPasteColumnWidths
                    .Cells(1).PasteSpecial xlPasteValuesAndNumberFormats
                    
                    If SheetExists(wsSource.Name, .Parent.Name) Then
                        j = 0
                        Do
                            j = j + 1
                            sNewNameWs = CStr(10 * j)
                        Loop Until SheetExists(sNewNameWs, .Parent.Name) = False
                        .Parent.Sheets(wsSource.Name).Name = sNewNameWs
                    End If
                    .Name = wsSource.Name
                End With
            End If
        Next
        
        'delete unneeded sheets
        For j = i + 1 To Application.SheetsInNewWorkbook
            Application.DisplayAlerts = False
            .Sheets(j).Delete
            Application.DisplayAlerts = True
        Next
        
        sFileSaveName = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.xls), *.xls")
        If sFileSaveName <> False Then
            .SaveAs sFileSaveName
            .Close
        Else: MsgBox "Het bestand werd niet opgeslagen.", vbInformation
        End If
    End With
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    Set wbSource = Nothing
    Set wbTarget = Nothing
    Set wsSource = Nothing
    Set wsTarget = Nothing
    
    MsgBox "Klaar!", vbInformation
End Sub

Function SheetExists(shName As String, wbName As String) As Boolean

'TRUE if the sheet with shName as name exists in the workbook named wbName (needs to be opened)
    
    On Error GoTo here
    If Len(Workbooks(wbName).Sheets(shName).Name) > 0 Then SheetExists = True
here:
End Function

 

[kaan]

WIGI en anderen,

Dit is een voorbeeld file.

Ik ben nu zover dat ik hem kan laten opslaan met een macro maar hij maakt nu enkel een kopie van de bestaande file en hij filtert niets uit.

Ik ga nu proberen om jou (WIGI) code te integreren las je dat voor mij kan doen graag? Dan ben ik weer een stap verder.

Dank

 

[Wigi]

Hier is alvast sterk ingekorte code:

Dim Pad As String
Dim Titel As String
Dim Gehelenaam As String

Sub Bewaar()

With Workbooks("Dagrapport.xls").Sheets(1)
    Titel = .Cells(3, 5) & " " & .Cells(3, 6) & " " & .Cells(3, 4) & " " & .Cells(3, 7)
    Pad = "G:\excel\Dagrapporten\" & .Parent.Sheets(1).Cells(3, 6) & "_" & .Parent.Sheets(1).Cells(3, 7)
End With

Gehelenaam = Pad & "\" & Titel

If PathExists(Pad) = False Then MkDir Pad 'Make a Dir
    
'Save de file
Titel = Titel & ".xls"
Workbooks("Dagrapport.xls").Worksheets(1).Activate
Workbooks("Dagrapport.xls").Sheets(Array("Deel_1", "Deel_2")).Select
Sheets(Array("Deel_1", "Deel_2")).Copy
Columns("AD:BB").ClearContents
Range("A1").Select
ActiveWorkbook.SaveAs Filename:=Gehelenaam
ActiveWindow.Close
Sheets("Deel_1").Select

End Sub 'Bewaar

Function PathExists(pname) As Boolean
'Return true if path exists
On Error Resume Next
PathExists = (GetAttr(pname) And vbDirectory)
End Function

Function FileExists(fname) As Boolean
    FileExists = Dir(fname) <> ""
End Function

Werk maar verder hiervan. Ik heb geen poging ondernomen om het op te lossen, enkel de code inkorten.

Wigi