Jump to content
Trelkrok

[Løst] Forkorte makro, Excel

Recommended Posts

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

 

Share this post


Link to post

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

Share this post


Link to post

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

Edited by Trelkrok

Share this post


Link to post
Annonse

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...

  • Recently Browsing   0 members

    No registered users viewing this page.

×
×
  • Create New...