03. maj 2007 - 14:08
Der er
2 kommentarer og
1 løsning
Udskrive kommentarer fra regneark sammen med udtræk
I ark1 har jeg vandret datoer og lodret vognnumre. Altså en vagtplan. I ark2 kan jeg ved at indtaste en dato, få den pågældende dags vogne frem på ark2 i rækkefølge lodret (sammen med nogle postnumre, som tages fra ark2). I ark1 har jeg indsat kommentarer, som jeg gerne vil have udskrevet samtidigt, så vognnumrene står lodret og kommentarerne lodret i kolonne f ved siden af den vogn, der er kommenatrer til.
Jeg mangler altså kun modulet til at få kommentarerne med, kan man indsætte et sådan?
mvh Johnny
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim kommentar As String
Dim Kol, t, r
If Intersect(Target, Range("C5")) Is Nothing Then Exit Sub
If Target > DateSerial(2007, 6, 17) Then GoTo Uge25
Kol = Application.Match(Target, Sheets("Ark1-1").Range("A3:FM3"), 0) 'find aktuel kolonne
Cells(1, 1) = Kol ' Slet evt. denne linie når du har testet koden
Range("D6:D32") = "" 'rset udtræk
For t = 4 To 29 ' Rækker i dit skema
Rem Slet gl. kommentarer
If t = 4 Then
Range("F6:F29").ClearContents
End If
r = Cells(40, 4).End(xlUp).Row + 1 ' finder næste tomme celle i udttræk
If Sheets("Ark1-1").Cells(t, Kol) = "" Then
Cells(r, 4) = Sheets("Ark1-1").Cells(t, 1)
Rem Slet variablen "kommentar"
kommentar = ""
Rem Hvis ingen kommentar i cellen - så fortsæt
On Error Resume Next
Rem hent kommentar fra cellen
kommentar = Sheets("Ark1-1").Cells(t, Kol).Comment.Text
Rem hvis kommentar findes - fjern den første linie
If kommentar <> "" Then
kommentar = fjernLinie1(kommentar)
End If
Cells(r, 6) = kommentar
End If
Next
GoTo ud
Uge25:
Kol = Application.Match(Target, Sheets("Ark1-1").Range("A30:FM30"), 0) 'find aktuel kolonne
Cells(2, 1) = Kol ' Slet evt. denne linie når du har testet koden
Range("D6:D32") = "" 'reset udtræk
For t = 4 To 29 ' Rækker i dit skema
r = Cells(40, 4).End(xlUp).Row + 1 ' finder næste tomme celle i udttræk
If Sheets("Ark1-1").Cells(t, Kol) = "" Then Cells(r, 4) = Sheets("Ark1-1").Cells(t, 1)
Next
ud:
End Sub
Private Function fjernLinie1(kommentar)
Dim p
p = InStr(kommentar, Chr(10))
If p > 0 Then
fjernLinie1 = Mid(kommentar, p + 1)
Else
fjernLinie1 = kommentar
End If
End Function
