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

CSV bestand weg schrijven met VBA uit excel.

Status
Niet open voor verdere reacties.
J

Johanjong1

Gebruiker
Lid geworden
17 dec 2019
Berichten
15
Ik heb een VBA script gemaakt voor CSV bestanden op te slaan met een ; scheiding teken.
Nu in het ene office wekt het juist en zie ik geen ; bij lege velden maar bij de ander wel.

zie bijlage voorbeeld op word bestand,en onderstaand het stuk VBA code.
Ik zie graag jullie reacties tegemoet

Werknummer = wsd.Range("B3").Value
Plaats = wsd.Range("B2").Value
IO = wsv.Range("E52").Value

Opmerking = wsv.Range("C56").Value
'Gegevens in regels zetten
x = ws.Range("diStartData2").Row
For i = y To wsd.Cells(Rows.Count, 2).End(xlUp).Row


Merk = wsd.Cells(i, 2).Value
aantal = wsd.Cells(i, 3).Value
hoog = wsd.Cells(i, wsd.Range("rcLengte").Column).Value
If wsd.Cells(i, wsd.Range("rcSoort").Column).Value <> "Type 1 (normaal)" Then
gekoppeld = "Gekoppeld met "
Else
gekoppeld = ""
End If

For j = 0 To UBound(Split(wst.Cells(i + 7, C).Value, ";"))
If UBound(Split(wst.Cells(i + 7, C).Value, ";")) > 1 Then
Select Case j
Case 0: merk1 = wsd.Cells(i, 2).Value & "_l"
Case 1: merk1 = wsd.Cells(i, 2).Value & "_m"
Case 2: merk1 = wsd.Cells(i, 2).Value & "_r"
End Select
ElseIf UBound(Split(wst.Cells(i + 7, C).Value, ";")) = 1 Then
Select Case j
Case 0: merk1 = wsd.Cells(i, 2).Value & "_l"
Case 1: merk1 = wsd.Cells(i, 2).Value & "_r"
End Select
Else
merk1 = wsd.Cells(i, 2).Value
End If
breed = Split(wst.Cells(i + 7, C).Value, ";")(j)


If wsd.Cells(i, wsd.Range("rTypedoek").Column).Value = "Satiné 5500" Then


ws.Range("A" & x).Value = Array(IO & "_" & Werknummer & "_" & merk1 & "_" & Plaats)
ws.Range("B" & x).Value = wsv.Range("F51").Value
ws.Range("D" & x & ":E" & x).Value = Array(breed, hoog)
ws.Range("C" & x).Value = Array(aantal)
ws.Range("G" & x).Value = wsv.Range("C52").Value

x = x + 1
ws.Cells(x - 1, 7).Value = wsd.Cells(i, wsd.Range("rTypedoek").Column).Value
ws.Cells(x - 1, 6).Value = wsd.Cells(i, wsd.Range("rKLnr").Column).Value
ws.Cells(x - 1, 11).Value = wsd.Cells(i, wsd.Range("Sunconfexoprolling").Column).Value
ws.Cells(x - 1, 8).Value = wsd.Cells(i, wsd.Range("rZichtzijdesun").Column).Value
ws.Cells(x - 1, 9).Value = wsd.Cells(i, wsd.Range("SunconfexBoven").Column).Value & "/" & wsd.Cells(i, wsd.Range("SunconfexOnder").Column).Value & "/" & wsd.Cells(i, wsd.Range("SunconfexZijKant").Column).Value

ws.Cells(x - 1, 17).Value = (Opmerking)
End If
If wsd.Cells(i, wsd.Range("rTypedoek").Column).Value = "Satiné 21154" Then


ws.Range("A" & x).Value = Array(IO & "_" & Werknummer & "_" & merk1 & "_" & Plaats)
ws.Range("B" & x).Value = wsv.Range("F51").Value
ws.Range("D" & x & ":E" & x).Value = Array(breed, hoog)
ws.Range("C" & x).Value = Array(aantal)


x = x + 1
ws.Cells(x - 1, 7).Value = wsd.Cells(i, wsd.Range("rTypedoek").Column).Value
ws.Cells(x - 1, 6).Value = wsd.Cells(i, wsd.Range("rKLnr").Column).Value
ws.Cells(x - 1, 11).Value = wsd.Cells(i, wsd.Range("Sunconfexoprolling").Column).Value
ws.Cells(x - 1, 8).Value = wsd.Cells(i, wsd.Range("rZichtzijdesun").Column).Value
ws.Cells(x - 1, 9).Value = wsd.Cells(i, wsd.Range("SunconfexBoven").Column).Value & "/" & wsd.Cells(i, wsd.Range("SunconfexOnder").Column).Value & "/" & wsd.Cells(i, wsd.Range("SunconfexZijKant").Column).Value

ws.Cells(x - 1, 17).Value = (Opmerking)
End If

Next j

If wsd.Cells(i, wsd.Range("rcMerk").Column).Value = "" Then
End
End If

Next i




Call BreakLinks(wb)
wb.saveas Replace(saveas, "/", "") & "_" & "Sunconfex" & "_" & ".CSV", FileFormat:=xlCSV, Local:=True
'FileFormat:=xlCSVMSDOS, CreateBackup:=False
wb.Close False
startstopevents (True)
Exit Sub
errhandler:
MsgBox Err.Description
startstopevents (True)
End Sub
 

Bijlagen

Ik heb een VBA script gemaakt voor CSV bestanden op te slaan met een ; scheiding teken.
Nu in het ene office wekt het juist en zie ik geen ; bij lege velden maar bij de ander wel.

zie bijlage voorbeeld op word bestand,en onderstaand het stuk VBA code.
Ik zie graag jullie reacties tegemoet.



Code: 
Sub DoekSunflex_genereren(saveas As String)

On Error GoTo errhandler:
startstopevents (False)[QUOTE][/QUOTE]
Dim wsd As Worksheet
Dim wstemp As Worksheet
Dim ws As Worksheet
Dim wsv As Worksheet
Dim wb As Workbook
Dim wst As Worksheet

Dim Kleur As String
Dim zichtzijde As String
Dim afwerkingboven As String
Dim afwerkingonder As String
Dim Afsealen As String
Dim doeksoort As String
Dim Snijrichting As String
Dim Zijdeafwerkingzijkant As String
Dim Zoomgroot As String
Dim Zijdeafwerkboven As String
Dim afwerkgrootonder As String
Dim Zijdeafwerkonder As String
Dim Speciaal As String
Dim Extra As String
Dim Leverweek As Long
Dim Opmerking As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False

y = 8
nextsheet:
Set wsd = UV_INM
Set wstemp = UH_SU
Set wsv = UV_VOOR
Set wst = UV_TG
C = Application.WorksheetFunction.Match("db", wst.Range("13:13"), 0)
If y = 8 Then
    Set wb = Application.Workbooks.Add
End If
wstemp.Copy wb.Sheets(1)
Set ws = wb.Sheets(1)
ws.Visible = xlSheetVisible
If y = 8 Then
    Do While wb.Sheets.Count > 1
        wb.Sheets(wb.Sheets.Count).Delete
    Loop
End If



Werknummer = wsd.Range("B3").Value
Plaats = wsd.Range("B2").Value
IO = wsv.Range("E52").Value

Opmerking = wsv.Range("C56").Value
'Gegevens in regels zetten
 x = ws.Range("diStartData2").Row
For i = y To wsd.Cells(Rows.Count, 2).End(xlUp).Row


        Merk = wsd.Cells(i, 2).Value
        aantal = wsd.Cells(i, 3).Value
        hoog = wsd.Cells(i, wsd.Range("rcLengte").Column).Value
        If wsd.Cells(i, wsd.Range("rcSoort").Column).Value <> "Type 1 (normaal)" Then
        gekoppeld = "Gekoppeld met "
        Else
        gekoppeld = ""
        End If
        
        For j = 0 To UBound(Split(wst.Cells(i + 7, C).Value, ";"))
            If UBound(Split(wst.Cells(i + 7, C).Value, ";")) > 1 Then
                Select Case j
                    Case 0: merk1 = wsd.Cells(i, 2).Value & "_l"
                    Case 1: merk1 = wsd.Cells(i, 2).Value & "_m"
                    Case 2: merk1 = wsd.Cells(i, 2).Value & "_r"
                End Select
            ElseIf UBound(Split(wst.Cells(i + 7, C).Value, ";")) = 1 Then
                Select Case j
                    Case 0: merk1 = wsd.Cells(i, 2).Value & "_l"
                    Case 1: merk1 = wsd.Cells(i, 2).Value & "_r"
                End Select
            Else
                merk1 = wsd.Cells(i, 2).Value
            End If
            breed = Split(wst.Cells(i + 7, C).Value, ";")(j)
                        
                        
            If wsd.Cells(i, wsd.Range("rTypedoek").Column).Value = "Satiné 5500" Then

            
            ws.Range("A" & x).Value = Array(IO & "_" & Werknummer & "_" & merk1 & "_" & Plaats)
            ws.Range("B" & x).Value = wsv.Range("F51").Value
            ws.Range("D" & x & ":E" & x).Value = Array(breed, hoog)
            ws.Range("C" & x).Value = Array(aantal)
            ws.Range("G" & x).Value = wsv.Range("C52").Value

            x = x + 1
            ws.Cells(x - 1, 7).Value = wsd.Cells(i, wsd.Range("rTypedoek").Column).Value
            ws.Cells(x - 1, 6).Value = wsd.Cells(i, wsd.Range("rKLnr").Column).Value
            ws.Cells(x - 1, 11).Value = wsd.Cells(i, wsd.Range("Sunconfexoprolling").Column).Value
            ws.Cells(x - 1, 8).Value = wsd.Cells(i, wsd.Range("rZichtzijdesun").Column).Value
            ws.Cells(x - 1, 9).Value = wsd.Cells(i, wsd.Range("SunconfexBoven").Column).Value & "/" & wsd.Cells(i, wsd.Range("SunconfexOnder").Column).Value & "/" & wsd.Cells(i, wsd.Range("SunconfexZijKant").Column).Value

            ws.Cells(x - 1, 17).Value = (Opmerking)
End If
            If wsd.Cells(i, wsd.Range("rTypedoek").Column).Value = "Satiné 21154" Then

            
            ws.Range("A" & x).Value = Array(IO & "_" & Werknummer & "_" & merk1 & "_" & Plaats)
            ws.Range("B" & x).Value = wsv.Range("F51").Value
            ws.Range("D" & x & ":E" & x).Value = Array(breed, hoog)
            ws.Range("C" & x).Value = Array(aantal)
            

            x = x + 1
            ws.Cells(x - 1, 7).Value = wsd.Cells(i, wsd.Range("rTypedoek").Column).Value
            ws.Cells(x - 1, 6).Value = wsd.Cells(i, wsd.Range("rKLnr").Column).Value
            ws.Cells(x - 1, 11).Value = wsd.Cells(i, wsd.Range("Sunconfexoprolling").Column).Value
            ws.Cells(x - 1, 8).Value = wsd.Cells(i, wsd.Range("rZichtzijdesun").Column).Value
            ws.Cells(x - 1, 9).Value = wsd.Cells(i, wsd.Range("SunconfexBoven").Column).Value & "/" & wsd.Cells(i, wsd.Range("SunconfexOnder").Column).Value & "/" & wsd.Cells(i, wsd.Range("SunconfexZijKant").Column).Value

            ws.Cells(x - 1, 17).Value = (Opmerking)
End If

            Next j

If wsd.Cells(i, wsd.Range("rcMerk").Column).Value = "" Then
End
End If

Next i



'Call Sunflex_Benaming

Call BreakLinks(wb)
wb.saveas Replace(saveas, "/", "") & "_" & "Sunconfex" & "_" & ".CSV", FileFormat:=xlCSV, Local:=True
'FileFormat:=xlCSVMSDOS, CreateBackup:=False
wb.Close False
startstopevents (True)
Exit Sub
errhandler:
MsgBox Err.Description
startstopevents (True)
End Sub
 

Bijlagen

#1 kan je aanpassen en ik zie het Excel document nog steeds niet. Het resultaat komt voort uit een bron:d
 
Als je alle ongebruikte rijen en kolommen verwijdert, werkt het dan wel?
 
Zonder je bronbestand of op zijn minst een anoniem gemaakte kopie ervan gaat het niet lukken je te helpen. Overigens als ik je code bekijk dan kan dit:
Code: 
y = 8
nextsheet:
Set wsd = UV_INM
Set wstemp = UH_SU
Set wsv = UV_VOOR
Set wst = UV_TG
C = Application.WorksheetFunction.Match("db", wst.Range("13:13"), 0)
If y = 8 Then
    Set wb = Application.Workbooks.Add
End If
wstemp.Copy wb.Sheets(1)
Set ws = wb.Sheets(1)
ws.Visible = xlSheetVisible
If y = 8 Then
    Do While wb.Sheets.Count > 1
        wb.Sheets(wb.Sheets.Count).Delete
    Loop
End If
vervangen worden door:
Code: 
nextsheet:
Set wsd = UV_INM
Set wstemp = UH_SU
Set wsv = UV_VOOR
Set wst = UV_TG
C = Application.WorksheetFunction.Match("db", wst.Range("13:13"), 0)
wstemp.Copy
Set wb ActiveWorkbook
Set ws = ActiveSheet
ws.Visible = xlSheetVisible
(er van uitgaande dat het blad dat wordt gekopieerd zichtbaar is)
 
Een deel van het Excel bestand waar mee het gegenereerd word

Hallo allemaal,

Hierbij het bestand waaruit de CSV word gegenereerd.
 

Bijlagen

Nu graag een voorbeeldbestand. Of moeten we eerste het hele project doorzoeken op wat waar staat? Verborgen bladen zichtbaar maken? ± 10 modules doorzoeken?
 
de test file in gevuld en voorbeeld

Hallo,


Bestand ingevuld en met de knop onder zaaglijsten Doekbon Sunflex Maken te genereren.
Wat ik wel vreemd vind op mijn PC werkt het zoals toegevoegd en de Fout doekbon is gemaakt met zelfde bestand op de pc waar het moet draaien.

Als je vragen of meer wenst te zien hoor ik het wel.
 

Bijlagen

Nu graag een voorbeeldbestand. Of moeten we eerste het hele project doorzoeken op wat waar staat? Verborgen bladen zichtbaar maken? ± 10 modules doorzoeken?
Klik om te vergroten...

Het opnieuw plaatsen van hetzelfde bestand en dezelfde probleem omschrijving voegt niets toe.
 
Zijn de instellingen op die Pc anders?

Scheidingsteken bv. een komma?
 
Sorry maar denk dat dit als voorbeeld kan werken ik hen een aantal gegevens er in geplaatst.
Het blad is zichtbaar waar het om gaat.
Doekbon Sunconfex.

Alles is in elkaar verweven dus als ik je een code en blad op stuur kan je niets zien waar van.
wat wil je dan precies zien als voorbeeld bestand?

Dacht dat je dir bedoelt.
 
Dat blad bestaat niet.
Deze wel (-1 is zichtbaar, 0 is verborgen.)
Code: 
Adres gegevens -1
Vrachtbrief -1
Voorblad -1
Doekbon 0
Inmeet gegevens_Screen maten -1
Totaal afkortmaten 0
Zaaglengtes 0
Moffelbon 0
Zaaglijst 0
Instellingen 0
Artikeldatabase 0
Totaal gegevens -1
Totaal lengtematerialen -1
Klaarleglijst 0
Lengtelijst -1
Helioscreen -1
ProductOmschrijving -1
Sunflex_Doek -1
Pakbon -1
Helios_Doek -1
Sticker 0
Sticker1 0
 
Laatst bewerkt:
Niet zo'n goed voorbeeldbestand, ik krijg een compileerfout en als ik die fix is het resultaat een geheel lege csv
 
Klopt excuus.

Klopt moet Sunflex_Doek zijn daar gaat het om.
deze haalt de gegevens van Inmeetgegevens_Screen maten.
En het blad instellingen deze is verborgen
Daar staat ook de plaats waar het weggeschreven moet worden.
die zal aangepast moeten worden op jullie plaats.dat id de bovenste regel geheel links.
daar onder is voor de moffelbon en nu niet van toepassing.
 
Hallo HSV,

Dat kan maar ik heb een bon met , en deze ;.
De lege cellen worden weer gegeven.
neem aan dat dat niet met de instellingen van de PC van doen heeft.
 
Met de plaats van opslaan heeft het niets te maken. Wel met de afwezigheid van een bepaalde routine uit je code.
 
Hallo Jan,

je kan eventueel even meekijken hoe het werkt.
het heeft te maken wie het uitwerk en of alles is ingevuld.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan