tabblad invoegen met gelijk de juiste celverwijzingen

[adkliko]

Hallo allemaal.
Ik heb een tabblad vm hoofdopdracht.
Dit formulier word ingevuld met gegevens.

Als je in kolom a een tekst in typed "pos 2" dan wordt er een leeg tabblad aangemaakt met de naam pos 2 dit gaat door tot pos 25
Echter wil ik dat de inhoud van werkblad "pos(1)" ook in de werkbladen 1 tot 25 terecht komen.
Maar dan ook dat alle cellen naar de juiste cellen in de VM hoofdopdracht verwijzen.

Dus cellen in tabblad pos 1 verwijzen naar cellen die op regel 8 staan.
De overige cellen verwijzen naar een vaste cel in de vm hoofdopdracht

ik kom er zelf namelijk niet meer uit.

groetjes marcel

 

[adkliko]

Een tabblad met inhoud toevoegen dmv het invullen van tekst is gelukt.
kijk bij deze post: http://www.helpmij.nl/forum/showthread.php/566043-automatisch-een-werkblad-aanmaken

echter blijft de verwijzing over.
wie kan me helpen.

 

[adkliko]

Wat ik zo lees is dat je iets met vert.zoeken kan doen. Ik heb echter geen idee hoe de formule er uit komt te zien.
=vert.zoeken(in "vm hoofdopdracht" naar bladnaam en haal gegevens op uit de cel B die in de rij staat van bladnaam)

 

[Mark xl]

De alles in één Macro.

Private Sub Worksheet_Change(ByVal Target As Range)
'Deze macro is geschreven door Mark Heuckeroth :P
Dim strcurrentsheet As String
If Target.Cells.Count = 1 Then
   '1 cel, kolom 1 en bevat tekst "pos"
    If Target.Column = 1 And LCase(Left(Target.Value, 3)) = "pos" Then

        'controleer of sheet al bestaat
        If Not SheetExists(Target.Value) Then
            'huidig werkblad naam onthouden, na macro terug naar huidig werkblad gaan
            strcurrentsheet = ActiveSheet.Name
            
            'blad toevoegen met ingevoerde naam
            Sheets("Pos (1)").Copy after:=Sheets(Sheets.Count)
            ActiveSheet.Name = Target.Value                     'naam van de cel aan blad toewijzen
            With Sheets(Target.Value)
                
                'Formules plaatsen (kan ook in hoofdsheet maar heb geen zin om up te loaden)
                .Cells.NumberFormat = "General"
                .Columns("H").Numberformat = "dd-mm-yy"
                .Columns("Q").Numberformat = "dd-mm-yy"
                .Columns("Z").Numberformat = "dd-mm-yy"
                .Range("B3") = Target.Value
                .Range("K3") = Target.Value
                .Range("T3") = Target.Value
                'deel 1
                .Range("D3").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,2,0)"
                .Range("B4").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,4,0)"
                .Range("D4").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,5,0)"
                .Range("H2").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,7,0)"
                'deel 2
                .Range("M3").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,2,0)"
                .Range("K4").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,4,0)"
                .Range("M4").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,5,0)"
                .Range("Q2").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,7,0)"
                'deel 3
                .Range("V3").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,2,0)"
                .Range("T4").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,4,0)"
                .Range("V4").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,5,0)"
                .Range("Z2").Formula = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,7,0)"
            End With
            'start werkblad opnieuw selecteren
            Sheets(strcurrentsheet).Activate
            'link naar nieuw blad maken
            With Target
                .Hyperlinks.Add Anchor:=Target, Address:="", _
                    SubAddress:="'" & Target.Value & "'!A1"
                'automatisch lelijke text terugformatteren naar bedoelde format (rood, etc.)
                .Font.Size = 11
                .Font.ColorIndex = 3
            End With
        
        End If
    
    End If

End If
End Sub
Function SheetExists(Sheetname As String) As Boolean
Dim sht As Worksheet
For Each sht In ActiveWorkbook.Worksheets
    If sht.Name = Sheetname Then
        SheetExists = True
        Exit For
    End If
Next
End Function

 

[ExcelAmateur]

Mark xl,

.Formula kun je eventueel weglaten.

.Range("D3") = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,2,0)"

 

[Mark xl]

Bedankt voor de tip Excelamateur, die zijn altijd welkom..!

Maar ik maak mijn programmacode graag zo duidelijk mogelijk. Natuurlijk is het voor de gemiddelde vba kenner duidelijk dat het hier over een Excel formule gaat.

Goede programmacode is niet zo kort mogelijk, maar zo inzichtelijk mogelijk. Voor iedereen die zich ervoor interesseert in mijn optiek, dus zet ik graag extra '.Formula' achter het bereik, zodat er geen twijfel over kan bestaan dat het een formule betreft.

Stel dat ik nu alles wat niet nodig is eens weg laat (in de sub)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim strcurrentsheet As String, i As Long
With Target
If .Cells.Count = 1 Then
If .Column = 1 And LCase(Left(.Value, 3)) = "pos" Then
If Not SheetExists(.Value) Then
strcurrentsheet = ActiveSheet.Name
Sheets("Pos (1)").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = .Value
With Sheets(.Value)
.Cells.NumberFormat = "General"
For i = 0 To 18 Step 9
.Range(Chr(66 + i) & 3) = Target
.Range(Chr(68 + i) & 3) = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,2,0)"
.Range(Chr(66 + i) & 4) = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,4,0)"
.Range(Chr(68 + i) & 4) = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,5,0)"
.Range(Chr(72 + i) & 3) = "=VLOOKUP(B3,'VM Hoofdopdracht'!A:M,7,0)"
.Range(.Range(Chr(72 + i) & 1), .Range(Chr(72 + i) & 2)).NumberFormat = "dd-mm-yy"
Next
End With
Sheets(strcurrentsheet).Activate
.Hyperlinks.Add Anchor:=Target, Address:="", _
SubAddress:="'" & .Value & "'!A1"
With .Font
.Size = 11
.ColorIndex = 3
End With
End If
End If
End If
End With
End Sub
Function SheetExists(Sheetname As String) As Boolean
Dim sht As Worksheet
For Each sht In ActiveWorkbook.Worksheets
    If sht.Name = Sheetname Then
        SheetExists = True
        Exit For
    End If
Next
End Function

Dat ziet er toch niet uit?
Het werkt wel, maar zo leest het veel minder makkelijk!

 

[adkliko]

Hoi mark.

Ik had reeds een oplossing gevonden via vertikaal zoeken.
ik zal deze hier plaatsen.
Heb echter die van jou ook geprobeerd en deze werkt zeer goed.
ik denk dat ik die maar neem.

thx voor de geweldige macro.

gr marcel