AW: Kopieren von Tabellenblättern
06.08.2005 15:19:22
Tabellenblättern
HAllo Luschi,
ja es handelt sich um einen kopierfehler. hir nochmal der ganze Code. Mein Problem ist, das Excel einfach abstürtzt. Warum weiß ich nicht. brauche dieses Tool aber wirklich dringend.
Module: Code:
Public objThisMap As Object
Public objMapAim As Object
Public StrFileLocation As String
Sub Export_VBA_Code()
'Variablendeklaration
Dim strAimFileName As String
Dim intStartCopy As Integer
Dim blnCopyFileExist As Boolean
'Tabelle ermitteln
StrFileLocation = "G:\Michael_Pelz\05_08_2005\964_pcpan_FuE_Test_Version\106_ress_Ressourcen_Kosten_Termine\"
strAimFileName = StrFileLocation & "Test1.xls"
'Abfrage, ob Uebertragung statfinden soll
intStartCopy = MsgBox("Wollen Sie die Tabellenblätter dieser Mappe in die Mappe" _
& vbNewLine & vbNewLine & strAimFileName & vbNewLine & vbNewLine _
& "kopieren?", vbInformation + vbYesNo, "Kopiren starten")
If intStartCopy = 6 Then
'Abfrage, ob Datei existiert
blnCopyFileExist = File_Exist(strAimFileName)
If blnCopyFileExist = True Then
'Arbeitsmappe Projektplan festlegen
Set objThisMap = ActiveWorkbook
'Sap_Data_File oeffnen und in Excelmappe einfügen
Workbooks.OpenText FileName:=strAimFileName
'Zielarbeitsmappe auswaehlen
Set objMapAim = ActiveWorkbook
'Tabelenblaetter kopieren
CopyWorkscheets objThisMap, objMapAim
'VBA Module Exportieren
alleMakrosExportieren
'VBA Module Importieren
Import1
'Mappe speichern und schließen und Exportfiles loeschen
'objMapAim.Close savechanges:=true
Del_Export_Files
ElseIf blnCopyFileExist = False Then
Exit Sub
End If
ElseIf intStartCopy = 7 Then
Exit Sub
End If
'Objecte entfernen
Set objThisMap = Nothing
Set objMapAim = Nothing
End Sub
Sub CopyWorkscheets(objThisMap As Object, objSearchMap As Object)
'Variablendeklaration
Dim VBComp As VBComponent
Dim VBCompSearch As VBComponent
Dim wksOld As Worksheet
Dim wksNew As Worksheet
Dim blnFind As Boolean
Dim strWorksheetsCopy As String
'Alle Tabelenblaetter freigeben
objThisMap.Activate
DieseArbeitsmappe.Alle_Tabellenblaetter_einblenden 'Hier ist eine Schleife, die die versteckten Tabellenblätter sichtbar macht (funktioniert)
For Each wksOld In objThisMap.Worksheets
For Each wksNew In objSearchMap.Worksheets
blnFind = False
If wksOld.name = wksNew.name Then
blnFind = True
End If
Next wksNew
If blnFind = False Then
strWorksheetsCopy = strWorksheetsCopy & vbNewLine & wksOld.name
ThisWorkbook.Worksheets(wksOld.name).Copy Before:=objSearchMap.Sheets(1)
End If
Next wksOld
MsgBox "Folgene Tabellenblätter wurden kopiert:" & vbNewLine & strWorksheetsCopy, _
vbInformation, "Kopierte Tabellenblätter"
'Tabellenblätter verbergen
DieseArbeitsmappe.Visible_Worksheets 'Hier ist eine Schleife, die gewisse Tabellenblätter versteckt(funktioniert)
'Loeschen von überflüssigen Tabellen
For Each wksNew In objSearchMap.Worksheets
If wksNew.name Like "Tabelle*" Then
Application.DisplayAlerts = False
wksNew.Delete
blnFind = True
Application.DisplayAlerts = True
End If
Next wksNew
End Sub
Public
Sub alleMakrosExportieren()
'Variablendeklaration
Dim vbc As Object, iCounter As Integer, sMacro As String, cType As String
For Each vbc In ThisWorkbook.VBProject.VBComponents
With vbc.CodeModule
For iCounter = 1 To .CountOfLines
If .ProcOfLine(iCounter, 0) > "" Or InStr(1, .Lines(iCounter, 1), "Dim") <> 0 _
Or InStr(1, .Lines(iCounter, 1), "Public") <> 0 Or InStr(1, .Lines(iCounter, 1), "Type") <> 0 _
Or InStr(1, .Lines(iCounter, 1), "Static") <> 0 Or InStr(1, .Lines(iCounter, 1), "Declare") <> 0 Then
Select Case vbc.Type
Case 1: cType = ".bas"
Case 2, 100: cType = ".cls"
Case 3: cType = ".frm"
End Select
Workbooks(ThisWorkbook.name).VBProject.VBComponents(vbc.name).Export StrFileLocation & vbc.name & cType
Exit For
End If
Next iCounter
End With
Next vbc
'Objecte entfernen
Set vbc = Nothing
End Sub
Public
Sub Import1()
'Variablendeklaration
Dim vbc As Object, iCounter As Integer, StDateiname As String, vbD As Object
With objMapAim.VBProject
For Each vbc In .VBComponents
'Loeschen der Module in der Zieldatei
Select Case vbc.Type
Case 1, 2, 3: .VBComponents.Remove .VBComponents(vbc.name)
Case 100
With vbc.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
'Module in Arbeitsmappe importieren
StDateiname = Dir(StrFileLocation & "*.*")
Do While StDateiname <> ""
If UCase(Right(StDateiname, 4)) = ".BAS" Or UCase(Right(StDateiname, 4)) = ".FRM" Or UCase(Right(StDateiname, 4)) = ".CLS" Then
.VBComponents.Import StrFileLocation & StDateiname
End If
StDateiname = Dir
Loop
'Objecte entfernen
Set vbc = Nothing
'VBA Code in Tabellenblaetter importieren
For Each vbD In .VBComponents
If vbD.Type = 2 Then
If Right(vbD.name, 1) = "1" Then
strTestetCode = vbD.CodeModule.Lines(1, vbD.CodeModule.CountOfLines)
.VBComponents(Left(vbD.name, Len(vbD.name) - 1)).CodeModule.InsertLines 1, strTestetCode
.VBComponents.Remove .VBComponents(vbD.name)
End If
End If
Next vbD
'Objecte entfernen
Set vbD = Nothing
End With
End Sub
Sub Del_Export_Files()
StDateiname = Dir(StrFileLocation & "*.*")
Do While StDateiname <> ""
If UCase(Right(StDateiname, 4)) = ".BAS" Or _
UCase(Right(StDateiname, 4)) = ".FRM" Or _
UCase(Right(StDateiname, 4)) = ".CLS" Or _
UCase(Right(StDateiname, 4)) = ".FRX" Then
Kill StrFileLocation & StDateiname
End If
StDateiname = Dir
Loop
End Sub
Gruß
Michael