Udtag Hvis= til andet ark X flere

Denne kan man jo bare bruge igen
Public Sub HT()
  With Worksheets("HT")
    .Rows(2).Insert
    With Range(.Cells(2, 1), .Cells(2, 4))
      .Value = vdB
      .Borders().LineStyle = xlContinuous
    End With
  End With
  ActiveWorkbook.Save
End Sub

for historie se : http://www.eksperten.dk/spm/659332

Arknavn må være det samme som testverdi, slik "HT" ble benyttet før.

Skriv inn de riktige verdier på denne linje:
If vTyp = "HT" Or vTyp = "GT" Or vTyp = "D10X" Or vTyp = "MKR" Then
(hvis du har riktig mange verdier, får vi finne en annen løsning)


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
  If Target.Address = Cells(5, 6).Address Then
    Target.Offset(, -3).Value = Trim(Target.Offset(, -3).Text)
    vTyp = UCase(Target.Offset(, -3).Text)
   
    If vTyp = "HT" Or vTyp = "GT" Or vTyp = "D10X" Or vTyp = "MKR" Then
      Target.Offset(, -3).Value = vTyp
    Else
      vTyp = 0
    End If
   
    For Each c In Range(Cells(5, 3), Cells(5, 4))
      If IsEmpty(c) Then
        Cells(5, 3).Select
        Exit Sub
      End If
    Next
    Cells(5, 6).FormulaR1C1 = "=now()"
   
    Call Add_vognløb
   
    If Not vTyp = 0 Then
      Call sTYPE
    End If
   
  End If
End Sub

obs!Skriv inn de riktige verdier på denne linje:
If vTyp = "HT" Or vTyp = "GT" Or vTyp = "D10X" Or vTyp = "MKR" Then
Dette gjelder selvfølgelig i :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Public vdB() As Variant
Public vTyp As Variant

Sub Add_vognløb()
  With Worksheets("Vognløb")
    With Range(.Cells(5, 3), .Cells(5, 6))
      vdB = .Value
      .ClearContents
      .Resize(1, 1).Select
    End With
    .Rows(11).Insert
    With Range(.Cells(11, 3), .Cells(11, 6))
      .Value = vdB
      .Borders().LineStyle = xlContinuous
      .Interior.ColorIndex = xlNone
    End With
  End With
  With Worksheets("Printliste")
    .Rows(2).Insert
   
    With Range(.Cells(2, 1), .Cells(2, 4))
      .Value = vdB
      .Borders().LineStyle = xlContinuous
    End With
     
  End With
  ActiveWorkbook.Save
End Sub


Public Sub sTYPE()

  With Worksheets(vTyp)
    .Rows(2).Insert
    With Range(.Cells(2, 1), .Cells(2, 4))
      .Value = vdB
      .Borders().LineStyle = xlContinuous
    End With
  End With
  ActiveWorkbook.Save
End Sub

gamle Public Sub HT()
har fått navnet Public Sub sTYPE()

Sub HT() skal ikke være med lengre

Det skal være ud på hver sit ark så de ikke er på samme ark kun på V-løb og printliste

der er Ca. 25 som skal tages fra på hver sit ark... :S

den virker man kun på ark vTyp. Hvis vi kalder dem X1 ;X2 osv. op til X25 så kan man vel bare omdøbe dem efter!?

Som du ser i Sub sType() :
istedet for navnet på arket, har vi lagt en varialbel med navn vTyp inn i,
With Worksheets(vTyp)
da vTyp kan ha alle dine 25 verdier, trenger du kun en versjon av
Public Sub sTYPE(), den virker på alle ark.

Hvis du har så mange som 25 verdier, er det bedre å benytte versjoen under.
der lister du bare opp navnene på dine ark.
HUSK! DINE ARK MÅ HA SAMME NAVN SOM DINE TESTVERDIER.
( som i gamle HT, her hadde arket og testverdien samme navn "HT")





Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim it As Variant
  Dim vTypeList() As Variant

    If Target.Address = Cells(5, 6).Address Then
       
    For Each c In Range(Cells(5, 3), Cells(5, 4))
      If IsEmpty(c) Then
        Cells(5, 3).Select
        Exit Sub
      End If
    Next
    Cells(5, 6).FormulaR1C1 = "=now()"
   
    With Cells(5, 3)
      Trim (.Text)
      .Value = UCase(.Text)
      vTyp = .Text
    End With
   
    Call Add_vognløb
   
    vTypeList = Array("HT", "GT", "D10X", "MKR")
    For Each it In vTypeList
      If vTyp = it Then Call sTYPE
    Next
   
  End If
End Sub

Skriv bare opp din liste i  vTypeList = Array("HT", "GT", "D10X", "MKR")
når du for mange verdier kan du benytt linjeskift på denne måten:

vTypeList = Array("HT", "GT",  _
            "D10X", "MKR")

_  underscore benyttes til å bryte koden i flere linjer

man kan også endre koden slik at man i celle (5,3)
kun har lov å taste en av dine 25 verdier,

Ark1(Vognløb)
Ark2(Printliste)
Ark3(HT)
Ark4(D10X)
Ark5(MKR)
Ark6(GT)

I Ark1 Kommer jeg denne kode ind
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim it As Variant
  Dim vTypeList() As Variant

    If Target.Address = Cells(5, 6).Address Then
       
    For Each c In Range(Cells(5, 3), Cells(5, 4))
      If IsEmpty(c) Then
        Cells(5, 3).Select
        Exit Sub
      End If
    Next
    Cells(5, 6).FormulaR1C1 = "=now()"
   
    With Cells(5, 3)
      Trim (.Text)
      .Value = UCase(.Text)
      vTyp = .Text
    End With
   
    Call Add_vognløb
   
    vTypeList = Array("HT", "GT", "D10X", "MKR")
    For Each it In vTypeList
      If vTyp = it Then Call sTYPE
    Next
   
  End If
End Sub

Og i Module1 disse koder
Public vdB() As Variant
Sub Add_vognløb()
  With Worksheets("Vognløb")
    With Range(.Cells(5, 3), .Cells(5, 6))
      vdB = .Value
      .ClearContents
      .Resize(1, 1).Select
    End With
    .Rows(11).Insert
    With Range(.Cells(11, 3), .Cells(11, 6))
      .Value = vdB
      .Borders().LineStyle = xlContinuous
      .Interior.ColorIndex = xlNone
    End With
  End With
  With Worksheets("Printliste")
    .Rows(2).Insert
   
    With Range(.Cells(2, 1), .Cells(2, 4))
      .Value = vdB
      .Borders().LineStyle = xlContinuous
    End With
     
  End With
  ActiveWorkbook.Save
End Sub
Public Sub sTYPE()

  With Worksheets("vTyp")
    .Rows(2).Insert
    With Range(.Cells(2, 1), .Cells(2, 4))
      .Value = vdB
      .Borders().LineStyle = xlContinuous
    End With
  End With
  ActiveWorkbook.Save
End Sub
-----
Men så laver den fejl på "With Worksheets("vTyp")"

du må ta bort gåseøyne i With Worksheets("vTyp")
skal være slik nå: With Worksheets(vTyp)

With Worksheets(vTyp)
    .Rows(2).Insert
    With Range(.Cells(2, 1), .Cells(2, 4))
      .Value = vdB
      .Borders().LineStyle = xlContinuous
    End With
  End With
  ActiveWorkbook.Save
End Sub
Hvis den set sådan ud laver den Rum-time error'9':
Subscript uot of range

begge disse declarasjonene må ligge øverst i modul1
Public vdB() As Variant
Public vTyp As Variant



i din execelbok må det være arkfaner, som inneholder hvert av disse navnene
("HT", "GT", "D10X", "MKR"),

din kode ser slik ut nå:

Public vdB() As Variant
Sub Add_vognløb()
...

la det være slik:
Public vdB() As Variant
Public vTyp As Variant
Sub Add_vognløb()
...

Jep det var lige det.. :D svaret er dit igen... Mange tak

vTypeList = Array("HT", "GT", "D10X", "MKR", "100", "322", "512")
Hvis jeg skriver det laver den fejl hvordan får jeg den til at tage nr:!?

se bort fra det sidste spørgsmål en fejl 40... :S

:o)

Er det muligt at smide en ekster celle ind!?
så den laver C=HT:D=NR.:EInfo:FTal:G=()NU

Er litt usikker på hva du mener nå.
ekstra celler, skal i være i sheet "vognløb"?
Kanskje det er letter å forstå hvis du forteller hva det skal benyttes til

Der er bare så det kommer en celle i mellem E og f / Bemærkning / Dato
Så dato bliver til G