Makro für kopieren von tabellenblättern

Hallo Entwicklergemeinde,
bin auf der suche nach einer smarten lösung für folgendes problem
ausgangsituation:
eine tabelle mit ca. 100 spalten mit informationen wo ich für ca. 250
artikel verschiedenste informationen angeben kann (alter container der
verwendet wurde, neuer container, gewicht, etc.)
für die übersichtliche darstellung für jeden einzelnen artikel gibt es
ein formularblatt für jeden einzelnen artikel (= jeweils ein
eigenständiges tabellenblatt)
wenn man in diesem formular die artikelnr. eingibt wird über einen
sverweis die jeweilige artikelinformation eingefügt.
problemstellung:
suche ein makro welches mir für jeden artikel eine kopie dieses
formularblattes erstellt und gleich die artikelnr einträgt und dies
eben für die anzahl der in der datentabelle gespeicherten artikel
(egal ob einmal 50 oder nächstesmal 200)
lässt sich dies einfach realsieren oder wäre es hier sinnvoller die
250 kopien händisch zu machen.
danke für unterstützung
lg
Jakob

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Jakob,
na dann viel Spass.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub generatePackingSheets()
    Dim objWsDaten As Worksheet, objWsForm As Worksheet
    Dim lngRow As Long, lngLast As Long

    On Error GoTo ErrExit
    GMS

    Set objWsDaten = Sheets("Daten")
    Set objWsForm = Sheets("packaging form")

    lngLast = Application.Max(6, objWsDaten.Cells(Rows.Count, 1).End(xlUp).Row)

    For lngRow = 6 To lngLast
        If objWsDaten.Cells(lngRow, 1) <> "" Then
            If Not SheetExist(objWsDaten.Cells(lngRow, 1).Value) Then
                objWsForm.Cells(7, 17) = objWsDaten.Cells(lngRow, 1).Value
                objWsForm.Copy after:=Sheets(Sheets.Count)
                Sheets(Sheets.Count).Name = CStr(objWsDaten.Cells(lngRow, 1).Value)
            End If
        End If
    Next

    ErrExit:
    If Err.Number <> 0 Then
        MsgBox "Fehler: " & Err.Number & vbLf & vbLf & Err.Description, Title:="Fehler"
    End If
    GMS True
    Set objWsDaten = Nothing
    Set objWsForm = Nothing
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
    Dim wks As Worksheet
    On Error GoTo ERRORHANDLER
    If WbName = "" Then WbName = ThisWorkbook.Name
    For Each wks In Workbooks(WbName).Worksheets
        If wks.Name = sheetName Then SheetExist = True: Exit Function
    Next
    ERRORHANDLER:
    SheetExist = False
End Function

Private Sub GMS(Optional ByVal Modus As Boolean = False)
    Static lngCalc As Long

    With Application
        .ScreenUpdating = Modus
        .EnableEvents = Modus
        .DisplayAlerts = Modus
        .EnableCancelKey = IIf(Modus, 1, 0)
        If Not Modus Then lngCalc = .Calculation
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Makro für kopieren von tabellenblättern

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro für kopieren von tabellenblättern

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread