MS Excel

Téma: aktualizace dat

Zaslal/a nio313 9.6.2010 16:38

Ahoj mam otazku mam macro na triedenie podla zadanej dodnoty diky JAZA.M. Potreboval bych este nejak aktualizovat data pri zmene hodnoty. Pri opetovnom zadani zmene pola vytvara duplicita. Viac prispevok FILTER .

Vzor tady :

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo x
If Target.Column = 4 Then
Dim sl As Single
Dim rd As Single
Select Case Target.Value
Case Is = 1
sl = 8
Case Is = 2
sl = 13
Case Is = 3
sl = 18
Case Is = 4
sl = 23
End Select
rd = 4
Do While Cells(rd, sl) <> ""
rd = rd + 1
Loop
Cells(rd, sl) = "'" & Cells(Target.Row, 1)
Cells(rd, sl + 1) = "'" & Cells(Target.Row, 2)
Cells(rd, sl + 2) = Cells(Target.Row, 3)

End If
x:
End Sub

Zaslat odpověď >

Jeza.m(10.6.2010 16:08)#001790

Tady jeden pokus:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo x
If Target.Column = 4 Then
Dim sl As Single
Dim rd As Single
Select Case Target.Value
Case Is = 1
sl = 8
Case Is = 2
sl = 12
Case Is = 3
sl = 16
Case Is = 4
sl = 20
End Select
Dim rd2 As Single
Dim wo As String
Dim pn As String
Dim pcs As Single

For sl2 = 8 To 20 Step 4
rd2 = 4
Do While Cells(rd2, sl2) <> ""
wo = Cells(Target.Row, 1)
pn = Cells(Target.Row, 2)
pcs = Cells(Target.Row, 3)

If Cells(rd2, sl2) = wo And Cells(rd2, sl2 + 1) = pn And Cells(rd2, sl2 + 2) = pcs Then
Range(Cells(rd2, sl2), Cells(rd2, sl2 + 2)).Delete Shift:=xlUp
rd2 = rd2 - 1
End If
rd2 = rd2 + 1

Loop
Next

rd = 4
Do While Cells(rd, sl) <> ""
rd = rd + 1
Loop
Cells(rd, sl) = "'" & Cells(Target.Row, 1)
Cells(rd, sl + 1) = "'" & Cells(Target.Row, 2)
Cells(rd, sl + 2) = Cells(Target.Row, 3)

End If
x:
End Sub
M@citovat

nio313(10.6.2010 16:38)#001791

Dakujem pekne toto je lepsia varianta povodne co si my navrhol som este predelal ale pri zadani inej hodnoty my to mazalo povodny s pola a prepisovalo do druheho a delalo bordel v dalsom sheete kde som mam tieto hodnoty s danych poli nalinkovane.

Este ras dik si borec.

citovat

Téma: aktualizace dat

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje