Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
984to988
984to988
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Tab kopieren und fortl. nummeriert in neue Datei

Tab kopieren und fortl. nummeriert in neue Datei
19.06.2008 16:12:00
Fritz_W
Hallo Forumsbesucher,
ich würde gerne per VBA-Lösung folgendes umsetzen:
wird in der Tabelle1 der Zellwert in Zelle A171 geändert (neue Eingabe), sollte die Tabelle1 kopiert und - sofern die Arbeitsmappe "Neu" geöffnet ist - die kopierte Tabelle (ohne Formeln, nur als Werte) in diese Arbeitsmappe ("Neu") als Tabelle "A1" einfügen. Gleichzeitig sollte die Tabelle2 der gleichen Arbeitsmappe kopiert werden und ebenfalls (ohne Formeln, nur die Werte) als Tabelle B1 in die geöffnete Arbeitsmappe "Neu" eingefügt werden. Bei der nächsten Veränderung sollten die Tabellen wie vorher ebenfalls kopiert und unter der Bezeichnung A2 bzw. B2 eingefügt werden. Bei der nächsten Veränderung Einfügung unter A3 und B3 usw.
Wäre nett, wenn sich das so in etwa realisieren ließe.
Vielen Dank für eure Unterstützung.
Gruß
Fritz

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tab kopieren und fortl. nummeriert in neue Datei
19.06.2008 20:03:00
Josef
Hallo Fritz,
kopiere den Code in das Modul der Tabelle "Tabelle 1". (Rechtsklick auf das Blattregister > Code Anzeigen)
Der Code ist ungetestet!
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit
Const cWorkBook As String = "C:\Pfad Zur Date\Neu.xls" 'Pfad und Name der Datei "Neu" - Anpassen!


Private Sub Worksheet_Change(ByVal Target As Range)
Dim objWB As Workbook, intIndex As Integer, blnWasOpen As Boolean

1 If Target.Address(0, 0) <> "A171" Then Exit Sub

2 On Error GoTo ErrExit
3 GMS

4 For Each objWB In Application.Workbooks
5 If objWB.FullName = cWorkBook Then
6 blnWasOpen = True
7 Exit For
8 End If
9 Next

10 If objWB Is Nothing Then
11 Set objWB = Workbooks.Open(cWorkBook)
12 End If

13 Do
14 intIndex = intIndex + 1
15 Loop While SheetExist("A" & intIndex, objWB.Name) = True

16 With ThisWorkbook
17 .Sheets("Tabelle 1").Copy after:=objWB.Sheets(objWB.Sheets.Count)
18 objWB.Sheets(objWB.Sheets.Count).Name = "A" & CStr(intIndex)
19 objWB.Sheets("A" & CStr(intIndex)).UsedRange = objWB.Sheets("A" & CStr(intIndex)).UsedRange.Value
20 .Sheets("Tabelle 2").Copy after:=objWB.Sheets(objWB.Sheets.Count)
21 objWB.Sheets(objWB.Sheets.Count).Name = "B" & CStr(intIndex)
22 objWB.Sheets("B" & CStr(intIndex)).UsedRange = objWB.Sheets("B" & CStr(intIndex)).UsedRange.Value
23 End With

24 If blnWasOpen Then objWB.Close True

ErrExit:
25 GMS True
26 If Err.Number > 0 Then
27 MsgBox "Es ist ein Fehler in Zeile " & CStr(Erl) & " aufgetreten!" & vbLf & vbLf & _
    "Fehlernummer:" & vbTab & Err.Number & vbLf & _
    "Fehlerquelle:" & vbTab & Err.Source & vbLf & _
    "Beschreibung:" & vbTab & Err.Description & Space(25), _
    vbExclamation, "Fehler"
28 End If
29 Err.Clear
End Sub

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 Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

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


Gruß Sepp



Anzeige
AW: Tab kopieren und fortl. nummeriert in neue Datei
20.06.2008 12:50:00
Fritz_W
Hallo Sepp,
ich bitte zunächst um Entschuldigung, weil ich mich so spät melde, aber ich konnte den Code
eben erst testen.
Das Ganze funktioniert - entsprechend meinen Vorgaben - einwandfrei.
Damit hast Du mir (wieder einmal) einen große Hilfe geleistet.
Vielen Dank!!!
Gruß
Fritz

@ Sepp - Ergänzung?
20.06.2008 16:11:03
Fritz_W
Hallo Sepp,
ist es sehr arbeitsaufwändig, den Code so zu verändern, dass in der kopierten Tabelle1 der im Tabellenblatt enthaltene Code in den jeweiligen Kopien (Tabellen "A1", "A2" usw) nicht mehr enthalten ist?
Bitte nur Änderungen vornehmen, wenn das für Dich nicht mit allzu viel Arbeit verbunden ist!
Ich bin mit der bisherigen Lösung ansonsten sehr zufrieden!!
Nochmaligen Dank
Gruß
Fritz

Anzeige
AW: @ Sepp - Ergänzung?
20.06.2008 20:45:00
Josef
Hallo
Fritz,
das ist kein Problem.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Const cWorkBook As String = "F:\Temp\Neu.xls" 'Pfad und Name der Datei "Neu" - Anpassen!


Private Sub Worksheet_Change(ByVal Target As Range)
Dim objWB As Workbook, intIndex As Integer, blnWasOpen As Boolean
Dim strCompA As String, strCompB As String

If Target.Address(0, 0) <> "A171" Then Exit Sub

On Error GoTo ErrExit
GMS

For Each objWB In Application.Workbooks
    If objWB.FullName = cWorkBook Then
        blnWasOpen = True
        Exit For
    End If
Next

If objWB Is Nothing Then
    Set objWB = Workbooks.Open(cWorkBook)
End If

Do
    intIndex = intIndex + 1
Loop While SheetExist("A" & intIndex, objWB.Name) = True

With objWB
    ThisWorkbook.Sheets("Tabelle 1").Copy after:=.Sheets(.Sheets.Count)
    .Sheets(.Sheets.Count).Name = "A" & CStr(intIndex)
    .Sheets("A" & CStr(intIndex)).UsedRange = .Sheets("A" & CStr(intIndex)).UsedRange.Value
    ThisWorkbook.Sheets("Tabelle 2").Copy after:=.Sheets(.Sheets.Count)
    .Sheets(.Sheets.Count).Name = "B" & CStr(intIndex)
    .Sheets("B" & CStr(intIndex)).UsedRange = .Sheets("B" & CStr(intIndex)).UsedRange.Value
    strCompA = .Sheets("A" & CStr(intIndex)).CodeName
    strCompB = .Sheets("B" & CStr(intIndex)).CodeName
    With .VBProject
        With .VBComponents(strCompA).CodeModule
            .DeleteLines 1, .CountOfLines
        End With
        With .VBComponents(strCompB).CodeModule
            .DeleteLines 1, .CountOfLines
        End With
    End With
End With

If Not blnWasOpen Then objWB.Close True
ThisWorkbook.Activate

ErrExit:
GMS True
If Err.Number > 0 Then
    MsgBox "Es ist ein Fehler in Zeile " & CStr(Erl) & " aufgetreten!" & vbLf & vbLf & _
        "Fehlernummer:" & vbTab & Err.Number & vbLf & _
        "Fehlerquelle:" & vbTab & Err.Source & vbLf & _
        "Beschreibung:" & vbTab & Err.Description & Space(25), _
        vbExclamation, "Fehler"
End If
Err.Clear
End Sub

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 Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

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


Gruß Sepp



Anzeige
etwas kürzer
20.06.2008 22:19:28
Josef
Hallo nochmal.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Const cWorkBook As String = "F:\Temp\Neu.xls" 'Pfad und Name der Datei "Neu" - Anpassen!

Private Sub Worksheet_Change(ByVal Target As Range)
Dim objWB As Workbook, intIndex As Integer, intCount As Integer, blnWasOpen As Boolean
Dim varSheetName() As Variant, varSheetToCopy() As Variant

1 If Target.Address(0, 0) <> "A171" Then Exit Sub

2 On Error GoTo ErrExit
3 GMS

4 varSheetName = Array("A", "B") 'Namen der Tabellen in "Neu.xls"
5 varSheetToCopy = Array("Tabelle 1", "Tabelle 2") 'Namen der zu kopierenden Tabellen

6 For Each objWB In Application.Workbooks
7 If objWB.FullName = cWorkBook Then
8 blnWasOpen = True
9 Exit For
10 End If
11 Next

12 If objWB Is Nothing Then
13 Set objWB = Workbooks.Open(cWorkBook)
14 End If

15 Do
16 intIndex = intIndex + 1
17 Loop While SheetExist(varSheetName(0) & CStr(intIndex), objWB.Name) = True

18 With objWB
19 For intCount = 0 To UBound(varSheetName)
20 ThisWorkbook.Sheets(varSheetToCopy(intCount)).Copy _
    after:=.Sheets(.Sheets.Count)
21 .Sheets(.Sheets.Count).Name = varSheetName(intCount) & CStr(intIndex)
22 .Sheets(varSheetName(intCount) & CStr(intIndex)).UsedRange = _
    .Sheets(varSheetName(intCount) & CStr(intIndex)).UsedRange.Value
23 With .VBProject.VBComponents(.Sheets(varSheetName(intCount) & _
    CStr(intIndex)).CodeName).CodeModule
24 .DeleteLines 1, .CountOfLines
25 End With
26 Next
27 End With

28 If Not blnWasOpen Then
29 objWB.Close True
30 Else
31 objWB.Save
32 End If

33 ThisWorkbook.Activate

ErrExit:
34 GMS True
35 If Err.Number > 0 Then
36 MsgBox "Es ist ein Fehler in Zeile " & CStr(Erl) & " aufgetreten!" & _
    vbLf & vbLf & "Fehlernummer:" & vbTab & Err.Number & vbLf & "Fehlerquelle:" & _
    vbTab & Err.Source & vbLf & "Beschreibung:" & vbTab & Err.Description & _
    Space(25), vbExclamation, "Fehler"
37 End If
38 Err.Clear
End Sub

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 Modus Then
        .Calculation = IIf(lngCalc <> 0, lngCalc, xlCalculationAutomatic)
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

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


Gruß Sepp



Anzeige
AW: etwas kürzer
20.06.2008 22:50:48
Fritz_W
Hallo Sepp,
vielen Dank, einfach Klasse!
Gruß
Fritz

308 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige