Formules vereenvoudigen!

Status
Niet open voor verdere reacties.
E

ExcelTonnie

Gebruiker
Lid geworden
5 jul 2016
Berichten
308
Om data te wijzigen in een tabel heb ik 4 onderdelen.

Aan de hand van een uniek nummer wordt een regel uit een tabel geselecteerd die ik kan wijzigen.

TxtST1 - t/m TxtST35
TxtLength1 - t/m TxtLength35
TxtCap1 - t/m TxtCap1 35
TxtCaps2 - t/m TxtCa2 35

Nu kan ik deze code 35x invoeren maar ga ervan uit dat dit een stuk eenvoudiger en korter kan.
Heb er 12 ingezet en is al een hele bups.
Hoe kan ik hetzelfde bereiken met minder code.


Code: 
Private Sub DataWijzigen_Click()
Dim lastrow
Dim X As String
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
X = TxtSSCCzoek.Text 'dit is het zoek invoerveld
For currentrow = 1 To lastrow

    If Cells(currentrow, 7).Text = X Then '7e kolom is waar de SSCC staan

ws1.Cells(currentrow, 8).Value = TxtST1.Text
ws1.Cells(currentrow, 9).Value = TxtLength1.Text
ws1.Cells(currentrow, 10).Value = Txt1Cap1.Text
ws1.Cells(currentrow, 11).Value = Txt2Cap1.Text

ws1.Cells(currentrow, 13).Value = TxtST2.Text
ws1.Cells(currentrow, 14).Value = TxtLength2.Text
ws1.Cells(currentrow, 15).Value = Txt1Cap2.Text
ws1.Cells(currentrow, 16).Value = Txt2Cap2.Text

ws1.Cells(currentrow, 18).Value = TxtST3.Text
ws1.Cells(currentrow, 19).Value = TxtLength3.Text
ws1.Cells(currentrow, 20).Value = Txt1Cap3.Text
ws1.Cells(currentrow, 21).Value = Txt2Cap3.Text
    
ws1.Cells(currentrow, 23).Value = TxtST4.Text
ws1.Cells(currentrow, 24).Value = TxtLength4.Text
ws1.Cells(currentrow, 25).Value = Txt1Cap4.Text
ws1.Cells(currentrow, 26).Value = Txt2Cap4.Text

ws1.Cells(currentrow, 28).Value = TxtST5.Text
ws1.Cells(currentrow, 29).Value = TxtLength5.Text
ws1.Cells(currentrow, 30).Value = Txt1Cap5.Text
ws1.Cells(currentrow, 31).Value = Txt2Cap5.Text

ws1.Cells(currentrow, 33).Value = TxtST6.Text
ws1.Cells(currentrow, 34).Value = TxtLength6.Text
ws1.Cells(currentrow, 35).Value = Txt1Cap6.Text
ws1.Cells(currentrow, 36).Value = Txt2Cap6.Text
    
ws1.Cells(currentrow, 38).Value = TxtST7.Text
ws1.Cells(currentrow, 39).Value = TxtLength7.Text
ws1.Cells(currentrow, 40).Value = Txt1Cap7.Text
ws1.Cells(currentrow, 41).Value = Txt2Cap7.Text

ws1.Cells(currentrow, 43).Value = TxtST8.Text
ws1.Cells(currentrow, 44).Value = TxtLength8.Text
ws1.Cells(currentrow, 45).Value = Txt1Cap8.Text
ws1.Cells(currentrow, 46).Value = Txt2Cap8.Text

ws1.Cells(currentrow, 58).Value = TxtST9.Text
ws1.Cells(currentrow, 59).Value = TxtLength9.Text
ws1.Cells(currentrow, 60).Value = Txt1Cap9.Text
ws1.Cells(currentrow, 61).Value = Txt2Cap9.Text
    
ws1.Cells(currentrow, 63).Value = TxtST10.Text
ws1.Cells(currentrow, 64).Value = TxtLength10.Text
ws1.Cells(currentrow, 65).Value = Txt1Cap10.Text
ws1.Cells(currentrow, 66).Value = Txt2Cap10.Text

ws1.Cells(currentrow, 68).Value = TxtST11.Text
ws1.Cells(currentrow, 69).Value = TxtLength11.Text
ws1.Cells(currentrow, 70).Value = Txt1Cap11.Text
ws1.Cells(currentrow, 71).Value = Txt2Cap11.Text

ws1.Cells(currentrow, 73).Value = TxtST12.Text
ws1.Cells(currentrow, 74).Value = TxtLength12.Text
ws1.Cells(currentrow, 75).Value = Txt1Cap12.Text
ws1.Cells(currentrow, 76).Value = Txt2Cap12.Text
    
    End If
Next currentrow
TxtSSCCzoek.SetFocus


End Sub
 
Bv.
Code: 
for currentrow = 1 to lastrow
for j = 1 to 20 step 5
   cells(currentrow, j+7) = me("txtst" & (j - 1) \ 4 + 1)
   cells(currentrow, j+8) = me("txtlenght" & (j - 1) \ 4 + 1)
   cells(currentrow, j+9) = me("txt1Cap" & (j - 1) \ 4 + 1)
   cells(currentrow, j+10) = me("txt2Cap" & (j - 1) \ 4 + 1)
next j
next currentrow

En dan moet je die 20 maar even zelf ophogen naar het juiste getal.
 
Mij lijkt 1 regel voldoende:

Code: 
Private Sub DataWijzigen_Click()
   sheet1.columns(7).find(TxtSSCCzoek).offset(,1).resize(,4)=array(TxtSSCCzoek,TxtLength1,xt1Cap1,xt1Cap2)
End Sub
 
Optie van alle 2 de heren geprobeerd echter kom ik daar niet uit.

Welke code vervangt wat mijn VBA.
Mijn Code:
Code: 
Private Sub DataWijzigen_Click()
Dim lastrow
Dim X As String
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
X = TxtSSCCzoek.Text 'dit is het zoek invoerveld
For currentrow = 1 To lastrow

    If Cells(currentrow, 7).Text = X Then '7e kolom is waar de SSCC staan

ws1.Cells(currentrow, 8).Value = TxtST1.Text
ws1.Cells(currentrow, 9).Value = TxtLength1.Text
ws1.Cells(currentrow, 10).Value = Txt1Cap1.Text
ws1.Cells(currentrow, 11).Value = Txt2Cap1.Text

ws1.Cells(currentrow, 13).Value = TxtST2.Text
ws1.Cells(currentrow, 14).Value = TxtLength2.Text
ws1.Cells(currentrow, 15).Value = Txt1Cap2.Text
ws1.Cells(currentrow, 16).Value = Txt2Cap2.Text

ws1.Cells(currentrow, 18).Value = TxtST3.Text
ws1.Cells(currentrow, 19).Value = TxtLength3.Text
ws1.Cells(currentrow, 20).Value = Txt1Cap3.Text
ws1.Cells(currentrow, 21).Value = Txt2Cap3.Text
    
ws1.Cells(currentrow, 23).Value = TxtST4.Text
ws1.Cells(currentrow, 24).Value = TxtLength4.Text
ws1.Cells(currentrow, 25).Value = Txt1Cap4.Text
ws1.Cells(currentrow, 26).Value = Txt2Cap4.Text

ws1.Cells(currentrow, 28).Value = TxtST5.Text
ws1.Cells(currentrow, 29).Value = TxtLength5.Text
ws1.Cells(currentrow, 30).Value = Txt1Cap5.Text
ws1.Cells(currentrow, 31).Value = Txt2Cap5.Text

ws1.Cells(currentrow, 33).Value = TxtST6.Text
ws1.Cells(currentrow, 34).Value = TxtLength6.Text
ws1.Cells(currentrow, 35).Value = Txt1Cap6.Text
ws1.Cells(currentrow, 36).Value = Txt2Cap6.Text
    
ws1.Cells(currentrow, 38).Value = TxtST7.Text
ws1.Cells(currentrow, 39).Value = TxtLength7.Text
ws1.Cells(currentrow, 40).Value = Txt1Cap7.Text
ws1.Cells(currentrow, 41).Value = Txt2Cap7.Text

ws1.Cells(currentrow, 43).Value = TxtST8.Text
ws1.Cells(currentrow, 44).Value = TxtLength8.Text
ws1.Cells(currentrow, 45).Value = Txt1Cap8.Text
ws1.Cells(currentrow, 46).Value = Txt2Cap8.Text

ws1.Cells(currentrow, 58).Value = TxtST9.Text
ws1.Cells(currentrow, 59).Value = TxtLength9.Text
ws1.Cells(currentrow, 60).Value = Txt1Cap9.Text
ws1.Cells(currentrow, 61).Value = Txt2Cap9.Text
    
ws1.Cells(currentrow, 63).Value = TxtST10.Text
ws1.Cells(currentrow, 64).Value = TxtLength10.Text
ws1.Cells(currentrow, 65).Value = Txt1Cap10.Text
ws1.Cells(currentrow, 66).Value = Txt2Cap10.Text

ws1.Cells(currentrow, 68).Value = TxtST11.Text
ws1.Cells(currentrow, 69).Value = TxtLength11.Text
ws1.Cells(currentrow, 70).Value = Txt1Cap11.Text
ws1.Cells(currentrow, 71).Value = Txt2Cap11.Text

ws1.Cells(currentrow, 73).Value = TxtST12.Text
ws1.Cells(currentrow, 74).Value = TxtLength12.Text
ws1.Cells(currentrow, 75).Value = Txt1Cap12.Text
ws1.Cells(currentrow, 76).Value = Txt2Cap12.Text
    
    End If
Next currentrow
TxtSSCCzoek.SetFocus


End Sub

SNB lijkt mij de kortste methode mits het werkt natuurlijk.
Code: 
Private Sub DataWijzigen_Click()
   sheet1.columns(7).find(TxtSSCCzoek).offset(,1).resize(,4)=array(TxtSSCCzoek,TxtLength1,xt1Cap1,xt1Cap2)
End Sub


Optie 2
HSV

Code: 
for currentrow = 1 to lastrow
for j = 1 to 20 step 5
   cells(currentrow, j+7) = me("txtst" & (j - 1) \ 4 + 1)
   cells(currentrow, j+8) = me("txtlenght" & (j - 1) \ 4 + 1)
   cells(currentrow, j+9) = me("txt1Cap" & (j - 1) \ 4 + 1)
   cells(currentrow, j+10) = me("txt2Cap" & (j - 1) \ 4 + 1)
next j
next currentrow
 
Plaats een bestand met het verwacht resultaat.
 
Bestanden die ik negeer:

- bestanden met samengevoegde cellen
- bestanden met wachtwoorden
- bestanden met meer dan 1 Userform
- bestanden met meer dan 1 macro-modules
- bestanden met VBA-code waarin gebruik gemaakt wordt van 'Select' of 'Activate'
- bestanden waarvan 98% van de informatie geen betrekking heeft op de gestelde vraag
 
Versie geheel uitgekleed en hoop dat dit geaccepteerd wordt.

Zoals eerder vermeld.
Knop Bewerkmodus, voor SSCC in bijv. 743330 >>> Meting laden

Wijzig bijv. een waarde van 1. en klik Wijziging activeren en data wordt aangepast.
 

Bijlagen

  • Helpmij2.xlsm
    46,4 KB · Weergaven: 38
Kort genoeg?
Code: 
Private Sub DataWijzigen_Click()
x = Application.Match(CLng(TxtSSCCzoek), Columns(7), 0)
 If IsNumeric(x) Then
  For j = 1 To 174 Step 5
   Cells(x, j + 7) = Me("txtst" & (j - 1) \ 5 + 1)
   Cells(x, j + 8) = Me("txtlength" & (j - 1) \ 5 + 1)
   Cells(x, j + 9) = Me("txt1Cap" & (j - 1) \ 5 + 1)
   Cells(x, j + 10) = Me("txt2Cap" & (j - 1) \ 5 + 1)
  Next j
 End If
End Sub

Kan ook in een array gezet worden als je dat liever hebt.
Code: 
Private Sub DataWijzigen_Click()
x = Application.Match(CLng(TxtSSCCzoek), Columns(7), 0)
 If IsNumeric(x) Then
  With Cells(x, 8).Resize(, 174)
     a = .Formula
      For j = 1 To 174 Step 5
       a(1, j) = Me("txtst" & (j - 1) \ 5 + 1)
       a(1, j + 1) = Me("txtlength" & (j - 1) \ 5 + 1)
       a(1, j + 2) = Me("txt1Cap" & (j - 1) \ 5 + 1)
       a(1, j + 3) = Me("txt2Cap" & (j - 1) \ 5 + 1)
      Next j
    .Formula = a
  End With
 End If
End Sub
 
Laatst bewerkt:
Inderdaad deze code is vele malen beter en kort genoeg.
Enige wat die doet na de wijzigingen is alle cellen van de gewijzigde regel de getallen links in de cel plaatsen.

Code: 
Private Sub DataWijzigen_Click()
x = Application.Match(CLng(TxtSSCCzoek), Columns(7), 0)
 If IsNumeric(x) Then
  For j = 1 To 174 Step 5
   Cells(x, j + 7) = Me("txtst" & (j - 1) \ 5 + 1)
   Cells(x, j + 8) = Me("txtlength" & (j - 1) \ 5 + 1)
   Cells(x, j + 9) = Me("txt1Cap" & (j - 1) \ 5 + 1)
   Cells(x, j + 10) = Me("txt2Cap" & (j - 1) \ 5 + 1)
  Next j
 End If
End Sub


Voor de herberekening nog een extra regel toegevoegd.
Werkt verder prima, Knap werk.

Code: 
Cells(X, j + 11) = (Cells(1, 16) * Cells(X, j + 8) \ Cells(X, j + 7))
 
Laatst bewerkt:
Verschuiving aangepast door.

Code: 
Range(Selection, Selection.End(xlToRight)).Select
 Range("A1").Select


Helaas pakt hij niet de actuele cel maar op regel 10
 
Laatst bewerkt:
Nog een vraag over hetzelfde bestand.
Om data uit een tabel te halen en plaatsen in het formulier heb ik de zelfde methode toegepast om data op te halen dus 35x.
Weet niet of ik hier een nieuw topic voor moet openen of dat de hier mag.


Code: 
Private Sub DataLaden_Click()
'Hiermee kun je data ophalen uit een tabel
Dim lastrow
Dim myname As String
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
myname = TxtSSCCzoek.Text 'Hier kun je aangeven in tekstbox 3 gezocht moet worden.
For currentrow = 2 To lastrow
If Cells(currentrow, 7).Text = myname Then '7 is de kolom waar de SSCC staan.

'Hieronder verschijnt de data in de tekstboxen
TxtST1.Text = ws1.Cells(currentrow, 8).Value
TxtLength1.Text = ws1.Cells(currentrow, 9).Value
Txt1Cap1.Text = ws1.Cells(currentrow, 10).Value
Txt2Cap1.Text = ws1.Cells(currentrow, 11).Value

TxtST2.Text = ws1.Cells(currentrow, 13).Value
TxtLength2.Text = ws1.Cells(currentrow, 14).Value
Txt1Cap2.Text = ws1.Cells(currentrow, 15).Value
Txt2Cap2.Text = ws1.Cells(currentrow, 16).Value

End If
If TxtSSCCzoek.Text = "" Then 'Hier ook de waarde veranderen waar myname tekstbox op staat.
MsgBox "No Data Found"

End If
Next currentrow
TxtSSCCzoek.SetFocus


End sub
 
De getallen rechts in de cel.
Code: 
Private Sub DataWijzigen_Click()
x = Application.Match(CLng(TxtSSCCzoek), Columns(7), 0)
 If IsNumeric(x) Then
  With Cells(x, 8).Resize(, 174)
     a = .Formula
      For j = 1 To 171 Step 5
       a(1, j) = CVar(Me("txtst" & (j - 1) \ 5 + 1))
       a(1, j + 1) = CVar(Me("txtlength" & (j - 1) \ 5 + 1))
       a(1, j + 2) = CVar(Me("txt1Cap" & (j - 1) \ 5 + 1))
       a(1, j + 3) = CVar(Me("txt2Cap" & (j - 1) \ 5 + 1))
      Next j
    .Formula = a
  End With
 End If
End Sub

Je vervolgvraag dan ook maar.
Code: 
Private Sub DataLaden_Click()
x = Application.Match(CLng(TxtSSCCzoek), Columns(7), 0)
 If IsNumeric(x) Then
   a = Cells(x, 8).Resize(, 174)
      For j = 1 To 171 Step 5
       Me("txtst" & (j - 1) \ 5 + 1) = a(1, j)
       Me("txtlength" & (j - 1) \ 5 + 1) = a(1, j + 1)
       Me("txt1Cap" & (j - 1) \ 5 + 1) = a(1, j + 2)
       Me("txt2Cap" & (j - 1) \ 5 + 1) = a(1, j + 3)
      Next j
 End If
 
Laatst bewerkt:
Onderstaande code werkt echter had ik ook een regel toegevoegd om een herberekening te laten uitvoeren.
Deze krijg ik niet werkend in de huidige code

Code: 
Private Sub DataWijzigen_Click()
x = Application.Match(CLng(TxtSSCCzoek), Columns(7), 0)
 If IsNumeric(x) Then
  With Cells(x, 8).Resize(, 174)
     a = .Formula
      For j = 1 To 171 Step 5
       a(1, j) = CVar(Me("txtst" & (j - 1) \ 5 + 1))
       a(1, j + 1) = CVar(Me("txtlength" & (j - 1) \ 5 + 1))
       a(1, j + 2) = CVar(Me("txt1Cap" & (j - 1) \ 5 + 1))
       a(1, j + 3) = CVar(Me("txt2Cap" & (j - 1) \ 5 + 1))
      Next j
    .Formula = a
  End With
 End If
End Sub


Code: 
Cells(X, j + 11) = (ws2.Range("t4").Value * Cells(X, j + 8) \ Cells(X, j + 7))
 
Dit bedoel je?

Code: 
Private Sub DataWijzigen_Click()
[COLOR=#ff0000]tel = Cells(1, 16)[/COLOR]
x = Application.Match(CLng(TxtSSCCzoek), Columns(7), 0)
 If IsNumeric(x) Then
  With Cells(x, 8).Resize(, 175)
     a = .Formula
      For j = 1 To 172 Step 5
       a(1, j) = CVar(Me("txtst" & (j - 1) \ 5 + 1))
       a(1, j + 1) = CVar(Me("txtlength" & (j - 1) \ 5 + 1))
       a(1, j + 2) = CVar(Me("txt1Cap" & (j - 1) \ 5 + 1))
       a(1, j + 3) = CVar(Me("txt2Cap" & (j - 1) \ 5 + 1))
[COLOR=#ff0000]       a(1, j + 4) = tel * a(1, j + 1) \ a(1, j)[/COLOR]
      Next j
    .Formula = a
  End With
 End If
End Sub
 
Allemaal bedankt voor jullie hulp.
HSV:

De code scheelt echt heeeeel veel.
Maar eens analyseren wat alles in die code betekent en doet.
Thx....again.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan