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

Invulblad wegschrijven naar database

Status
Niet open voor verdere reacties.
N

nexus one

Gebruiker
Lid geworden
11 dec 2010
Berichten
9
Hallo allemaal,

Ik heb een invulblad gemaakt en nu wil ik de resultaten wegschrijven in de database op een ander werkblad.
Ik heb al diverse forumoplossingen proberen te verbouwen naar eigen wens, maar helaas heb ik nu ook de meeste foutmeldingen van VBA wel gezien :confused:

Het is uiteindelijk de bedoeling dat door een klik op het logo de data wordt weggeschreven naar de database.

Bij voorbaat bedankt

Nexus One
 
Je combobox heb ik gelinkt aan cel C7.

Code: 
Sub wegschrijven()
 With Sheets("D_visueel")
 .[A65536].End(xlUp).Offset(1).Resize(, 4) = _
  WorksheetFunction.Transpose(Sheets("Formulier D_visueel").Range("C5:C8"))
 .[A65536].End(xlUp).Offset(, 4).Resize(, 5) = _
  WorksheetFunction.Transpose(Sheets("Formulier D_visueel").Range("I16:I20"))
 .[A65536].End(xlUp).Offset(, 9).Resize(, 3) = _
  WorksheetFunction.Transpose(Sheets("Formulier D_visueel").Range("I24:I26"))
 .[A65536].End(xlUp).Offset(, 12) = Sheets("Formulier D_visueel").Range("I29")
 .[A65536].End(xlUp).Offset(, 13) = Sheets("Formulier D_visueel").Range("I32")
 .[A65536].End(xlUp).Offset(, 14) = Sheets("Formulier D_visueel").Range("I34")
 .[A65536].End(xlUp).Offset(, 15) = Sheets("Formulier D_visueel").Range("C38")
 .[A65536].End(xlUp).Offset(, 16) = Sheets("Formulier D_visueel").Range("C9")
 .Columns("A:Q").AutoFit
End With
 MsgBox "Alles is weggeschreven"
End Sub
 

Bijlagen

Laatst bewerkt:
Of zo
Code: 
Sub wegschrijven()
 With [D_visueel!A65536].End(xlUp)
    .Offset(1).Resize(, 4) = Application.Transpose(['Formulier D_visueel'!C5:C8])
    .Offset(1, 4).Resize(, 5) = Application.Transpose(['Formulier D_visueel'!I16:I20])
    .Offset(1, 9).Resize(, 3) = Application.Transpose(['Formulier D_visueel'!I24:I26])
    With Sheets("Formulier D_Visueel")
        sq = .[I29] & "|" & .[I32] & "|" & .[I34] & "|" & .[C38] & "|" & .[C9]
    End With
    .Offset(1, 12).Resize(, 5) = Split(sq, "|")
End With
Columns("A:Q").AutoFit
MsgBox "Alles is weggeschreven"
End Sub
 
Kleine aanpassing Rudi.

Code: 
Sheets("D_visueel").Columns("A:Q").AutoFit

Ik zal me ook eens verdiepen in de split functie. :thumb:
 
Bedankt HSV,

Werkt als een zonnetje :cool:
Als ik het goed begrijpt werkt dit ongeveer net als een draaitabel?

Misschien dat een cursus VBA me goed zal doen :o

VRGR Peter
 
Nou, een draaitabel is toch heel iets anders.

Maar mooi dat het werkt Peter. :thumb:
 
Ben ik toch nog een keer.

Om te voorkomen dat er dubbele tagnummers worden ingevoerd wil ik graag voor het wegschrijven het tagnummer op de sheet D_visueel vergelijken met de tagnummers uit de tabel.
Als een tagnummer al voorkomt (exact) dan moet de keuze worden gegeven
1) bestaande gegevens overschrijven, of
2) nieuw record aanmaken

Hints in de goede richting zijn al welkom
 
Probeer het zo eens.
Code: 
Sub wegschrijven()

Set tagnummer = Sheets("D_visueel").Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row).Find([C6], , xlValues)
rij = Application.WorksheetFunction.Match(tagnummer, Sheets("D_visueel").Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row), 0)
If tagnummer Is Nothing Then GoTo einde
If MsgBox("Tagnummer bestaat al " & Chr(10) & Chr(10) & "Wilt u overschrijven ", vbYesNo, "Let Op") = vbYes Then
  With Sheets("D_visueel").Range("A" & rij + 1)
   .Resize(, 4) = Application.Transpose(['Formulier D_visueel'!C5:C8])
    .Offset(, 4).Resize(, 5) = Application.Transpose(['Formulier D_visueel'!I16:I20])
    .Offset(, 9).Resize(, 3) = Application.Transpose(['Formulier D_visueel'!I24:I26])
    With Sheets("Formulier D_Visueel")
        sq = .[I29] & "|" & .[I32] & "|" & .[I34] & "|" & .[C38] & "|" & .[C9]
    End With
    .Offset(, 12).Resize(, 5) = Split(sq, "|")
   End With
 Exit Sub
Else
  End If
einde:  With [D_visueel!A65536].End(xlUp)
        .Offset(1).Resize(, 4) = Application.Transpose(['Formulier D_visueel'!C5:C8])
        .Offset(1, 4).Resize(, 5) = Application.Transpose(['Formulier D_visueel'!I16:I20])
        .Offset(1, 9).Resize(, 3) = Application.Transpose(['Formulier D_visueel'!I24:I26])
    With Sheets("Formulier D_Visueel")
        sq = .[I29] & "|" & .[I32] & "|" & .[I34] & "|" & .[C38] & "|" & .[C9]
      End With
    .Offset(1, 12).Resize(, 5) = Split(sq, "|")
  End With
 Sheets("D_visueel").Columns("A:Q").AutoFit
MsgBox "Alles is weggeschreven"
End Sub
 
Harry,

Bij het invoeren van een niet bestaand tagnummer krijg ik de fout:

"Ongeldige procedure-aanroep of ongeldig argument"
Kan dit komen omdat er geen match is en het resultaat #N/B is?

Ik wilde nog het resultaat bijvoegen maar het uploaden werkte niet mee :(
De uiteindelijke code is geworden:

Sub wegschrijven()

Set tagnummer = Sheets("D_visueel").Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row).Find([C5], , xlValues)
Rij = Application.WorksheetFunction.Match(tagnummer, Sheets("D_visueel").Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row), 0)
If tagnummer Is Nothing Then GoTo einde
If MsgBox("Tagnummer bestaat al " & Chr(10) & Chr(10) & "Wilt u overschrijven ", vbYesNo, "Let Op") = vbYes Then
With Sheets("D_visueel").Range("A" & Rij + 1)
.Resize(, 4) = Application.Transpose(['Formulier D_visueel'!C5:C8])
.Offset(, 4).Resize(, 5) = Application.Transpose(['Formulier D_visueel'!I16:I20])
.Offset(, 9).Resize(, 3) = Application.Transpose(['Formulier D_visueel'!I24:I26])
With Sheets("Formulier D_Visueel")
sq = .[I29] & "|" & .[I32] & "|" & .[I34] & "|" & .[C38] & "|" & .[C9] & "|" & .[C39]
End With
.Offset(, 12).Resize(, 6) = Split(sq, "|")
End With
'
' sorteren Macro
'

'
Sheets("D_visueel").Select
ActiveWorkbook.Worksheets("D_visueel").ListObjects("Tabel1").Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("D_visueel").ListObjects("Tabel1").Sort.SortFields. _
Add Key:=Range("Tabel1[[#All],[Tagnummer]]"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("D_visueel").ListObjects("Tabel1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Exit Sub
Else
End If
einde: With [D_visueel!A65536].End(xlUp)
.Offset(1).Resize(, 4) = Application.Transpose(['Formulier D_visueel'!C5:C8])
.Offset(1, 4).Resize(, 5) = Application.Transpose(['Formulier D_visueel'!I16:I20])
.Offset(1, 9).Resize(, 3) = Application.Transpose(['Formulier D_visueel'!I24:I26])
With Sheets("Formulier D_Visueel")
sq = .[I29] & "|" & .[I32] & "|" & .[I34] & "|" & .[C38] & "|" & .[C9] & "|" & .[C39]
End With
.Offset(1, 12).Resize(, 6) = Split(sq, "|")
End With
Sheets("D_visueel").Columns("A:Q").AutoFit
MsgBox "Alles is weggeschreven"

'
' sorteren Macro
'

'
Sheets("D_visueel").Select
ActiveWorkbook.Worksheets("D_visueel").ListObjects("Tabel1").Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("D_visueel").ListObjects("Tabel1").Sort.SortFields. _
Add Key:=Range("Tabel1[[#All],[Tagnummer]]"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("D_visueel").ListObjects("Tabel1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

Het tagnummerveld is verhuist naar C5 en kolom A in de tabel.

Bedankt

PS. gelijk werk gemaakt van die split functie :thumb:
 
Probeer het bestandje eens te zippen of te rarren (moet sowieso bij .xlsm extensies).

Plaats je code graag tussen de codetags zoals ik ook gebruik.
Geef anders ook aan op welke regel het fout gaat.
 
ipv
Code: 
Set tagnummer = Sheets("D_visueel").Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row).Find([C5], , xlValues)
Rij = Application.WorksheetFunction.Match(tagnummer, Sheets("D_visueel").Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row), 0)
If tagnummer Is Nothing Then GoTo einde
zo
Code: 
Set tagnummer = Sheets("D_visueel").Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row).Find([C5], , xlValues)
If tagnummer Is Nothing Then GoTo einde
Rij = Application.WorksheetFunction.Match(tagnummer, Sheets("D_visueel").Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row), 0)
Op die manier wordt het rijnummer pas gecontroleerd als het tagnummer al bestaat.
 
Het omdraaien van die twee regels was idd de oplossing.

Sorry voor die lange tekst, maar ik had het al geplaatst toen ik er aan dacht om de code tag te gebruiken. ('t was al laat he)
Code: 
Ik zal m'n leven beteren :cool:
Het uploaden van een bestand werkte niet lekker met IE9, maar alsnog het voorlopige resultaat bij deze.
Nogmaals bedankt
 

Bijlagen

Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan