Code läuft jetzt
13.01.2006 21:09:11
Reinhard
Hi urs,
vielleicht bist du ja daran interessiert:
Die Auflistung wird auf Blatt2 Duckfertig zubereitet um möglichst immer gesamtcode auf einem Blatt zu haben.
Gruß
Reinhard
Option Explicit
Public wb As String
Public Const Sterne = "*************************************************************************"
Sub test2()
Dim i As Long, zei As Long
Dim objWks As Object
Application.ScreenUpdating = False
Range("A1:C1").EntireColumn.Clear
Set objWks = ThisWorkbook.Sheets("Tabelle1")
wb = "kilahukwiss.xls"
Workbooks.Open CurDir & "\" & wb
For i = 1 To Workbooks(wb).VBProject.VBComponents.Count
Call ExCode(Workbooks(wb).VBProject.VBComponents(i).Name, objWks)
Next i
ActiveWorkbook.Close
zei = objWks.Range("A65536").End(xlUp).Row
objWks.Cells(zei, 1) = "End Sub" 'k.A. warum, das letzte End sub fehlt *g
objWks.Range("A1").Select
Call Druckfertig2
Application.ScreenUpdating = True
End Sub
Sub Druckfertig2()
Dim Druckzeilen As Integer, ende As Long, n As Long, anz As Integer, von(), bis(), pos2 As Long
Dim ws2 As Worksheet, anz2 As Integer
Druckzeilen = 56 'Arial10, 11=50, 12=47
Set ws2 = Worksheets("Tabelle2")
pos2 = 1
With Worksheets("Tabelle1")
ende = .Range("A65536").End(xlUp).Row
For n = 1 To ende
If Cells(n, 1) = Sterne Then
anz = anz + 1
ReDim Preserve von(anz)
von(anz) = n
End If
Next n
ReDim bis(anz)
For n = 1 To anz - 1
bis(n) = von(n + 1) - 1
Next n
bis(n) = ende
For n = 1 To anz - 1
anz2 = 0
While bis(n) - von(n) + 1 > Druckzeilen
.Range(Cells(von(n), 1), Cells(von(n) + Druckzeilen - 1, 1)).Copy ws2.Cells(pos2, 1)
pos2 = pos2 + Druckzeilen
von(n) = von(n) + Druckzeilen
Wend
If .Cells(von(n), 1) <> Sterne Then
.Range(Cells(von(n), 1), Cells(bis(n)), 1).Copy ws2.Cells(pos2, 1)
pos2 = pos2 + Druckzeilen
End If
While bis(n) - von(n) + bis(n + 1) - von(n + 1) + 2 < Druckzeilen
n = n + 1
von(n) = von(n - 1)
Wend
.Range(Cells(von(n), 1), Cells(bis(n), 1)).Copy ws2.Cells(pos2, 1)
pos2 = pos2 + Druckzeilen
Next n
If von(n) <> von(n - 1) Then .Range(Cells(von(n), 1), Cells(bis(n), 1)).Copy ws2.Cells(pos2, 1)
.Columns.AutoFit
End With
End Sub
Sub ExCode(strModulName As String, objTB As Object)
Dim intZ As Long, zei As Long
Dim strArr
With Workbooks(wb).VBProject
ReDim strArr(0 To .VBComponents(strModulName).CodeModule.CountOfLines - 1)
For intZ = 1 To .VBComponents(strModulName).CodeModule.CountOfLines
strArr(intZ - 1) = .VBComponents(strModulName).CodeModule.Lines(intZ, 1)
Next
End With
With objTB
zei = .Range("A65536").End(xlUp).Row
If .Cells(1, 1) = "" Then zei = 0
.Cells(zei + 1, 1) = Sterne
.Cells(zei + 2, 1) = strModulName
For intZ = 1 To UBound(strArr) + 1
.Cells(zei + 2 + intZ, 1) = strArr(intZ - 1)
Next
.Columns.AutoFit
End With
End Sub