Tabellenblätter erstellen

Hallo liebe Forumsmitglieder,
ich habe hier ein kleines Problem, bei dem ihr mich sicherlich unterstützen könnt:
Ich habe eine Datei mit einem Tabellenblatt Namens Übersicht. In diesem Blatt werden untereinander Artikel aufgelistet. Bsp:
Spalte A: Gerätetyp
Spalte B: Gerätebezeichnung
Spalte C: Bearbeiter
Spalte D: Link
Jetzt ist es so, dass ich in den einzelnen Reihen z.B. PCs, Monitore etc. eintrage. Ich möchte jetzt nach Eingabe des Gerätetyps und der Gerätebezeichnung, dass
1. ein Tabellenblatt mit dem Namen aus Spalte B erstellt wird
2. in Spalte D ein Link erzeugt wird, der mich sofort auf das entsprechende Tabellenblatt bringt.
Nun meine Frage:
1. Wie kann ich es einrichten, dass automatisch ein neues Tabellenblatt mit dem entsprechenden Namen erstellt wird und
2. Wie kann ich es einrichten, dass der Link erstellt wird?
Bei Frage 1 habe ich das Problem, dass automatisch erkannt werden muss, in welcher Zeile ich gerade ein Produkt anlege. Die Spalte bleibt ja immer "B".
Ich hoffe, dass ich meine Frage und Problemstellung verständlich erklärt habe und ihr mir helfen könnt.
Vielen Dank im Voraus!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim objRange As Range, objCell As Range Dim objWorksheet As Worksheet Set objRange = Intersect(Target, Columns(2)) If Not objRange Is Nothing Then For Each objCell In objRange If Application.CountIf(Columns(2), objCell.Text) = 1 Then With ThisWorkbook Set objWorksheet = .Worksheets.Add( _ After:=.Worksheets(.Worksheets.Count)) End With objWorksheet.Name = objCell.Offset(0, -1).Text & " - " & objCell.Text Call Hyperlinks.Add(Anchor:=objCell.Offset(0, 2), Address:=vbNullString, _ SubAddress:="'" & objWorksheet.Name & "'!A1", TextToDisplay:=objWorksheet.Name) Set objWorksheet = Nothing End If Next Set objRange = Nothing Call Activate End If End Sub

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim objRange As Range, objCell As Range Dim objWorksheet As Worksheet Dim strName As String, strFirstAddress As String Set objRange = Intersect(Target, Columns(2)) If Not objRange Is Nothing Then For Each objCell In objRange strName = objCell.Offset(0, -1).Text & " - " & objCell.Text For Each objWorksheet In ThisWorkbook.Worksheets If objWorksheet.Name = strName Then Exit For Next If objWorksheet Is Nothing Then With ThisWorkbook Set objWorksheet = .Worksheets.Add( _ After:=.Worksheets(.Worksheets.Count)) End With objWorksheet.Name = strName Call Hyperlinks.Add(Anchor:=objCell.Offset(0, 2), Address:=vbNullString, _ SubAddress:="'" & strName & "'!A1", TextToDisplay:=strName) Set objWorksheet = Nothing End If Next Set objRange = Nothing Call Activate End If Set objRange = Intersect(Target, Columns(6)) If Not objRange Is Nothing Then With ThisWorkbook For Each objCell In objRange strName = objCell.Offset(0, -5).Text & " - " & objCell.Offset(0, -4).Text If Application.CountBlank(.Worksheets(strName).Cells) = .Worksheets(strName).Cells.CountLarge Then If objCell.Text = "Alt" Then Call .Worksheets("Testung").Cells.Copy(Destination:=.Worksheets(strName).Cells(1, 1)) ElseIf objCell.Text = "Neu" Then Call .Worksheets("Ausschreibung").Cells.Copy(Destination:=.Worksheets(strName).Cells(1, 1)) End If End If Next End With Set objRange = Nothing End If End Sub

Hallo,
teste mal:


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objRange As Range, objCell As Range
Dim objWorksheet As Worksheet
Dim strName As String, strFirstAddress As String
Set objRange = Intersect(Target, Columns(2))
If Not objRange Is Nothing Then
For Each objCell In objRange
strName = objCell.Offset(0, -1).Text & " - " & objCell.Text
For Each objWorksheet In ThisWorkbook.Worksheets
If objWorksheet.Name = strName Then Exit For
Next
If objWorksheet Is Nothing Then
With ThisWorkbook
Set objWorksheet = .Worksheets.Add( _
After:=.Worksheets(.Worksheets.Count))
End With
objWorksheet.Name = strName
Call Hyperlinks.Add(Anchor:=objCell.Offset(0, 2), Address:=vbNullString, _
SubAddress:="'" & strName & "'!A1", TextToDisplay:=strName)
Set objWorksheet = Nothing
End If
Next
Set objRange = Nothing
Call Activate
End If
Set objRange = Intersect(Target, Columns(6))
If Not objRange Is Nothing Then
With ThisWorkbook
For Each objCell In objRange
strName = objCell.Offset(0, -5).Text & " - " & objCell.Offset(0, -4).Text
If Application.CountBlank(.Worksheets(strName).Cells) = .Worksheets(strName).Cells.CountLarge Then
If objCell.Text = "Alt" Then
Call .Worksheets("Testung").Cells.Copy(Destination:=.Worksheets(strName).Cells(1, 1))
ElseIf objCell.Text = "Neu" Then
Call .Worksheets("Ausschreibung").Cells.Copy(Destination:=.Worksheets(strName).Cells(1, 1))
End If
.Worksheets(strName).Cells(1, 5).Value = objCell.Offset(0, -4).Text
.Worksheets(strName).Cells(2, 5).Value = objCell.Offset(0, -3).Text
End If
Next
End With
Set objRange = Nothing
End If
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread