Gå til innhold

[Løst] Forkorte makro, Excel

Trelkrok

Av Trelkrok
i Programvare

Anbefalte innlegg

Trelkrok

Trelkrok

Skrevet
Skrevet

Hei, har Norsk Excel, Office 365

Kan denne forkortes? Eventuelt hvordan??

 

Private Sub Worksheet_Change(ByVal Target As Range)

 Dim kol As Integer

 Dim rad As Integer

 

 Dim Tekstkol As Integer

 Dim DatoKol As Integer

 Dim TidKol As Integer

 

 'Område 1

 Tekstkol = 5

 DatoKol = 4 

 kol = Target.Column

 rad = Target.Row

 

 If kol = Tekstkol And rad > 2 Then 'Håpper over 2 rader. Raden begynner her 1, 2, eller 3

  If Target.Value <> "" Then

   If Cells(rad, DatoKol) = "" Then

    Cells(rad, DatoKol) = Left(Now(), 10)

   End If

  Else

    Cells(rad, DatoKol) = ""

    Cells(rad, TidKol) = ""

  End If

 End If

 

 'Område 2

 Tekstkol = 9

 DatoKol = 8

 kol = Target.Column

 rad = Target.Row

 

 If kol = Tekstkol And rad > 2 Then 'Håpper over 2 rader. Raden begynner her 1, 2, eller 3

  If Target.Value <> "" Then

   If Cells(rad, DatoKol) = "" Then

    Cells(rad, DatoKol) = Left(Now(), 10)

   End If

  Else

    Cells(rad, DatoKol) = ""

    Cells(rad, TidKol) = ""

  End If

 End If

 

 'Område 3

 Tekstkol = 13

 DatoKol = 12 

 kol = Target.Column

 rad = Target.Row

 

 If kol = Tekstkol And rad > 2 Then 'Håpper over 2 rader. Raden begynner her 1, 2, eller 3

  If Target.Value <> "" Then

   If Cells(rad, DatoKol) = "" Then

    Cells(rad, DatoKol) = Left(Now(), 10)

   End If

  Else

    Cells(rad, DatoKol) = ""

    Cells(rad, TidKol) = ""

  End If

 End If

 

 'Område 4

 Tekstkol = 17

 DatoKol = 16 

 kol = Target.Column

 rad = Target.Row

 

 If kol = Tekstkol And rad > 2 Then 'Håpper over 2 rader. Raden begynner her 1, 2, eller 3

  If Target.Value <> "" Then

   If Cells(rad, DatoKol) = "" Then

    Cells(rad, DatoKol) = Left(Now(), 10)

   End If

  Else

    Cells(rad, DatoKol) = ""

    Cells(rad, TidKol) = ""

  End If

 End If

 

 'Område 5

 Tekstkol = 21

 DatoKol = 20 

 kol = Target.Column

 rad = Target.Row

 

 If kol = Tekstkol And rad > 2 Then 'Håpper over 2 rader. Raden begynner her 1, 2, eller 3

  If Target.Value <> "" Then

   If Cells(rad, DatoKol) = "" Then

    Cells(rad, DatoKol) = Left(Now(), 10)

   End If

  Else

    Cells(rad, DatoKol) = ""

    Cells(rad, TidKol) = ""

  End If

 End If

 

 'Område 6

 Tekstkol = 25

 DatoKol = 24

kol = Target.Column

 rad = Target.Row

 

 If kol = Tekstkol And rad > 2 Then 'Håpper over 2 rader. Raden begynner her 1, 2, eller 3

  If Target.Value <> "" Then

   If Cells(rad, DatoKol) = "" Then

    Cells(rad, DatoKol) = Left(Now(), 10)

   End If

  Else

    Cells(rad, DatoKol) = ""

    Cells(rad, TidKol) = ""

  End If

 End If

 

 'Område 7

 Tekstkol = 29

 DatoKol = 28

 'TidKol = 2 

 kol = Target.Column

 rad = Target.Row

 

 If kol = Tekstkol And rad > 2 Then 'Håpper over 2 rader. Raden begynner her 1, 2, eller 3

  If Target.Value <> "" Then

   If Cells(rad, DatoKol) = "" Then

    Cells(rad, DatoKol) = Left(Now(), 10)

   End If

  Else

    Cells(rad, DatoKol) = ""

    Cells(rad, TidKol) = ""

  End If

 End If

 

 'Område 8

 Tekstkol = 33

 DatoKol = 32 

 kol = Target.Column

 rad = Target.Row

 

 If kol = Tekstkol And rad > 2 Then 'Håpper over 2 rader. Raden begynner her 1, 2, eller 3

  If Target.Value <> "" Then

   If Cells(rad, DatoKol) = "" Then

    Cells(rad, DatoKol) = Left(Now(), 10)

   End If

  Else

    Cells(rad, DatoKol) = ""

    Cells(rad, TidKol) = ""

  End If

 End If

 

 'Område 9

 Tekstkol = 37

 DatoKol = 36

kol = Target.Column

 rad = Target.Row

 

 If kol = Tekstkol And rad > 2 Then 'Håpper over 2 rader. Raden begynner her 1, 2, eller 3

  If Target.Value <> "" Then

   If Cells(rad, DatoKol) = "" Then

    Cells(rad, DatoKol) = Left(Now(), 10)

   End If

  Else

    Cells(rad, DatoKol) = ""

    Cells(rad, TidKol) = ""

  End If

 End If

 

 'Område 10

 Tekstkol = 41

 DatoKol = 40

kol = Target.Column

 rad = Target.Row

 

 If kol = Tekstkol And rad > 2 Then 'Håpper over 2 rader. Raden begynner her 1, 2, eller 3

  If Target.Value <> "" Then

   If Cells(rad, DatoKol) = "" Then

    Cells(rad, DatoKol) = Left(Now(), 10)

   End If

  Else

    Cells(rad, DatoKol) = ""

    Cells(rad, TidKol) = ""

  End If

 End If

 

 

End Sub

 

Lenke til kommentar

Videoannonse

Videoannonse
Annonse
Harald Staff

Harald Staff

Skrevet
Skrevet

Hei

 

Den kan forkortes betraktelig.

Men først: Target kan være et større celleområde dersom du bruker fyllhåndtaket, eller hvis du limer inn et celleområde. Da har ikke Target nødvendigvis en rad eller kolonne, og så havarerer koden.

 

Her er et par sjørøvertricks. Enten sjekke Target(1), som er cella lengst til venstre øverst i Target:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target(1).Row = 5 Then

som regel er det jo bare denne ene. Eller loope hver eneste celle i Target:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cel As Range
For Each Cel In Target
    If Cel.Row = 5 Then

Du kan også sjekke om det er en eller flere celler som er endret:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then
    'flere celler

Så til spørsmålet. Hvis jeg skjønner riktig så skal hver fjerde kolonne fom E få en dato til venstre for seg hvis det ikke står en der fra før. Jeg ville løst det med Select Case slik -vi bruker den late måten og sjekker bare Target(1):

Private Sub Worksheet_Change(ByVal Target As Range)
If Target(1).Row < 3 Then Exit Sub
Select Case Target(1).Column
    Case 5, 9, 13, 17, 21, 25, 29 'fyll på videre
        If Target(1).Offset(0, -1).Value < 100 Then Target.Offset(0, -1).Value = Date
    Case Else
        'do nothing
End Select
End Sub

Beste hilsen Harald

Lenke til kommentar
Trelkrok

Trelkrok

Skrevet
  • Forfatter
Skrevet (endret)

Hei

 

Den kan forkortes betraktelig.

Men først: Target kan være et større celleområde dersom du bruker fyllhåndtaket, eller hvis du limer inn et celleområde. Da har ikke Target nødvendigvis en rad eller kolonne, og så havarerer koden.

 

Her er et par sjørøvertricks. Enten sjekke Target(1), som er cella lengst til venstre øverst i Target:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target(1).Row = 5 Then

som regel er det jo bare denne ene. Eller loope hver eneste celle i Target:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cel As Range
For Each Cel In Target
    If Cel.Row = 5 Then

Du kan også sjekke om det er en eller flere celler som er endret:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then
    'flere celler

Så til spørsmålet. Hvis jeg skjønner riktig så skal hver fjerde kolonne fom E få en dato til venstre for seg hvis det ikke står en der fra før. Jeg ville løst det med Select Case slik -vi bruker den late måten og sjekker bare Target(1):

Private Sub Worksheet_Change(ByVal Target As Range)
If Target(1).Row < 3 Then Exit Sub
Select Case Target(1).Column
    Case 5, 9, 13, 17, 21, 25, 29 'fyll på videre
        If Target(1).Offset(0, -1).Value < 100 Then Target.Offset(0, -1).Value = Date
    Case Else
        'do nothing
End Select
End Sub

Beste hilsen Harald

Endret av Trelkrok
Lenke til kommentar

Opprett en konto eller logg inn for å kommentere

Du må være et medlem for å kunne skrive en kommentar

Opprett konto

Det er enkelt å melde seg inn for å starte en ny konto!

Start en konto

Logg inn

Har du allerede en konto? Logg inn her.

Logg inn nå
Gå til emneliste

  • Hvem er aktive   0 medlemmer

    • Ingen innloggede medlemmer aktive
×
×
  • Opprett ny...