AW: mal ganz anders:
20.11.2012 15:43:16
Pepi
Hallo Klaus
Ist ja wirklich toll, wie Du Dich meinem Anliegen annimmst. Gerne kopiere ich den Code in dieses Forum - auch wenn ich mich etwas schäme. Habe nicht Alles selber gestrickt - verstehe aus diesem Grund auch nicht Alles. Die Zeit von 45Min. ist grundsätzlich kein Problem, da ich dies zum Glück nur selten eine defekte Datei habe (schneller wäre natürlich besser). Bestimmt gibt es viel Potential, das Makro schlanker und schneller und vor allem einen Code zu kreieren, der am Schluss keine Hänger, Abstürze, oder sonst welche Schwierigkeiten bietet. Ich hoffe, dass Dich dies nicht zu viel Zeit in Anspruch nimmt. Nach dem Makro muss ich jeweils noch die Makros und Userform kopieren und die bedingte Formatierung setzen.
Auf jeden Fall vielen Dank!!
Sub SU_Arbeitsmapppe_Zellenweise_kopieren() 'Zellenweise 07.03.11
Dim iZeiAnz As Long, iSpaAnz As Integer, j As Integer, n As Integer, z As Long, s As Integer, x As Integer
Dim iLee As Integer, iTab As Integer, iAnf As Integer, iZei As Long
Dim sQue As String, sZie As String, sTab As String, sTmp As String
Dim oQue As Object, oZie As Object, oT9 As Object, oWB As Workbook, Var As Variant
Const iMax = 50
Const iSGr As Integer = 10 'Schriftgrösse
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set oT9 = ThisWorkbook.Sheets(Tab999.Name).Cells()
' ---------------------------------------------------------------------------------------------
ThisWorkbook.Activate
For Each oWB In Workbooks 'Alle Mappen schliessen, ausser dieser
sTmp = oWB.Name
If sTmp ThisWorkbook.Name And LCase(sTmp) "personal.xlsb" Then oWB.Close False
Next
' ---------------------------------------------------------------------------------------------
' Arbeitsmappe öffnen, die kopiert werden soll
sTmp = oT9(1, 2) 'Speicherplatz, der zuletzt geöffneten Mappe
If Not FU_Ordner_Vorhanden(sTmp) Then sTmp = ThisWorkbook.Path
If Mid(sTmp, 2, 1) = ":" Then ChDrive Left(sTmp, 2)
ChDir sTmp
Var = Application.GetOpenFilename(FileFilter:="Excel Dateien (*.xls*), *.xls*", MultiSelect:=False)
If Var = False Then Exit Sub
Workbooks.Open Var
sQue = Dir(Var)
j = InStr(StrReverse(sQue), ".")
sZie = Left(sQue, (Len(sQue) - j)) & "_Neu" & Right(sQue, j)
Workbooks.Add 'Neue Tabelle wird im gleichen Excel-Format wie die Forlage gespeichert
ActiveWorkbook.SaveAs Filename:=Workbooks(sQue).Path & "\" & sZie, FileFormat:=Workbooks(sQue).FileFormat, CreateBackup:=False
oT9(1, 2) = Workbooks(sQue).Path
iZei = 3
oT9(iZei, 2) = "Start um"
oT9(iZei, 3) = Left(Time, 5)
'oT9(4, 3) = Empty
iAnf = Val(oT9(2, 2))
If Workbooks(sQue).Sheets.Count = iAnf Then
MsgBox "Dir Arbeitsmappe >" & sQue & "
Exit Sub
End If
' =============================================================================================
ThisWorkbook.Activate
iTab = Workbooks(sQue).Sheets.Count
If iAnf = 0 Then iAnf = 1
If iAnf > 1 Then
If iAnf
j = MsgBox("Start bei >" & Sheets(iAnf).Name & "
If j = vbNo Then Exit Sub
Else
MsgBox iAnf & " ist ein falscher Startwert - Abbruch!", vbExclamation
Exit Sub
End If
Else
Call SU_Tabellen_Struktur_Vergleichen(Workbooks(sQue), Workbooks(sZie)) 'gleiche Anzahl Blätter, Namen, CodeNamen
End If
' ---------------------------------------------------------------------------------------------
For x = iAnf To iTab
Set oZie = Workbooks(sZie).Sheets(x).Cells() 'ZielDatei
Set oQue = Workbooks(sQue).Sheets(x).Cells() 'QuellDatei
Workbooks(sQue).Activate
Sheets(x).Activate
Workbooks(sQue).Sheets(x).Unprotect
iZei = iZei + 1
oT9(iZei, 2) = x & " von " & iTab & " * " & Sheets(x).Name & " - kopieren - Zeit: " & Left(oT9(3, 3).Text, 5) & "_" & Left(Time, 5)
Application.StatusBar = x & " von " & iTab & " * " & Sheets(x).Name & " - Verbundende Zelle entfernen - Zeit: " & Left(oT9(3, 3).Text, 5) & "_" & Left(Time, 5)
Call SU_Verbundene_Zellen_Merken_Entfernen(Workbooks(sQue), x) 'OriginalDatei
'Workbooks(sQue).Sheets(x).Cells.Locked = False 'Zellen nicht gesperrt
'Workbooks(sQue).Sheets(x).Cells.FormulaHidden = False 'Zellen nicht ausgeblendet
sTab = Sheets(x).Name
' ---------------------------------------------------------------------------------------------
iZeiAnz = 0: iSpaAnz = 0
'Zeilen zählen
For s = 1 To 13
iLee = 0
z = 1
Do While iLee
If Trim(oQue(z, s)) = "" Then
iLee = iLee + 1
Else
iLee = 0
End If
z = z + 1
Loop
If (z - iLee - 1) > iZeiAnz Then iZeiAnz = z - iLee - 1
Next s
' ------------------------------------------------------------------------------------------
'Spalten zählen
For z = 1 To 15
iLee = 0
s = 1
Do While iLee
If Trim(oQue(z, s)) = "" Then
iLee = iLee + 1
Else
iLee = 0
End If
s = s + 1
Loop
If (s - iLee - 1) > iSpaAnz Then iSpaAnz = s - iLee - 1
Next z
If iZeiAnz = 0 Or iSpaAnz = 0 Then Exit Sub
'MsgBox x & "/" & iTab & " = " & sTab & vbLf & iZeiAnz & " Zeilen" & vbLf & iSpaAnz & " Spalten"
' ------------------------------------------------------------------------------------------
Workbooks(sZie).Activate
Sheets(x).Activate
oZie.Font.Name = "Arial"
oZie.Font.Size = iSGr
iSpaAnz = 2 ' test
For s = 1 To iSpaAnz
Application.StatusBar = Workbooks(sQue).Sheets(x).Name & " kopieren > Spalte " & s & " von " & iSpaAnz & " Spalten - Zeit: " & Left(oT9(3, 3).Text, 5) & "_" & Left(Time, 5)
Columns(s).ColumnWidth = Workbooks(sQue).Sheets(x).Columns(s).ColumnWidth
For z = 1 To iZeiAnz
If oQue(z, s) "" Then oZie(z, s).Formula = Trim(oQue(z, s).Formula) 'trim() geht nicht
If s = 1 Then Rows(z).RowHeight = Workbooks(sQue).Sheets(x).Rows(z).RowHeight
If oZie(z, s).NumberFormat oQue(z, s).NumberFormat Then oZie(z, s).NumberFormat = oQue(z, s).NumberFormat 'DatenFormat
If oZie(z, s).Locked oQue(z, s).Locked Then oZie(z, s).Locked = oQue(z, s).Locked 'Zellen nicht gesperrt
If oZie(z, s).FormulaHidden oQue(z, s).FormulaHidden Then oZie(z, s).FormulaHidden = oQue(z, s).FormulaHidden 'Zellen nicht ausgeblendet
If oQue(z, s).Interior.ColorIndex xlNone Then oZie(z, s).Interior.Color = oQue(z, s).Interior.Color
If oQue(z, s).Font.ColorIndex xlAutomatic Then oZie(z, s).Font.Color = oQue(z, s).Font.Color 'Schriftfarbe
If oQue(z, s).Font.Bold = True Then oZie(z, s).Font.Bold = True 'Fett
If oQue(z, s).Font.Size iSGr Then oZie(z, s).Font.Size = oQue(z, s).Font.Size 'Schriftgrösse
If oQue(z, s).Font.Underline = xlUnderlineStyleSingle Then oZie(z, s).Font.Underline = xlUnderlineStyleSingle 'Unterstreichen
If oQue(z, s).Font.Underline = xlUnderlineStyleDouble Then oZie(z, s).Font.Underline = xlUnderlineStyleDouble 'Unterstreichen
If oQue(z, s).Font.Strikethrough = True Then oZie(z, s).Font.Strikethrough = True 'Durchgestriechen
If oQue(z, s).WrapText = True Then oZie(z, s).WrapText = True 'Zeilenumbruch
If oQue(z, s).Orientation 0 Then oZie(z, s).Orientation = oQue(z, s).Orientation 'Text drehen
If oQue(z, s).HorizontalAlignment xlGeneral Then oZie(z, s).HorizontalAlignment = oQue(z, s).HorizontalAlignment
If oQue(z, s).VerticalAlignment xlBottom Then oZie(z, s).VerticalAlignment = oQue(z, s).VerticalAlignment
If oQue(z, s).Borders(xlEdgeLeft).LineStyle xlNone Then oZie(z, s).Borders(xlEdgeLeft).Weight = oQue(z, s).Borders(xlEdgeLeft).Weight
If oQue(z, s).Borders(xlEdgeRight).LineStyle xlNone Then oZie(z, s).Borders(xlEdgeRight).Weight = oQue(z, s).Borders(xlEdgeRight).Weight
If oQue(z, s).Borders(xlEdgeTop).LineStyle xlNone Then oZie(z, s).Borders(xlEdgeTop).Weight = oQue(z, s).Borders(xlEdgeTop).Weight
If oQue(z, s).Borders(xlEdgeBottom).LineStyle xlNone Then oZie(z, s).Borders(xlEdgeBottom).Weight = oQue(z, s).Borders(xlEdgeBottom).Weight
Next z
Next s
' ==========================================================================================
Application.StatusBar = Sheets(x).Name & " - Zellen verbinden - Zeit: " & Left(oT9(3, 3).Text, 5) & "_" & Left(Time, 5)
Call SU_Zellen_Verbinden(Workbooks(sZie), x) 'in Tabelle x
Application.StatusBar = Sheets(x).Name & " - Seite formatieren - Zeit: " & Left(oT9(3, 3).Text, 5) & "_" & Left(Time, 5)
Call SU_Seitenformatierung(Workbooks(sQue), Workbooks(sZie), x)
Application.StatusBar = ThisWorkbook.Name & " - speichern - Zeit: " & Left(oT9(3, 3).Text, 5) & "_" & Left(Time, 5)
oT9(2, 2) = x
If x = 1 Then oT9(2, 3) = "von " & iTab
Workbooks(sZie).Save
'Exit For 'Test nur Seite 1
Next x 'nächstes Tabellenblatt
' =============================================================================================
sTmp = "_Namen kopieren - Zeit: " & Left(oT9(3, 3).Text, 5) & "_" & Left(Time, 5)
iZei = iZei + 1
oT9(iZei, 2) = sTmp
Application.StatusBar = sTmp
'Call SU_Names_Copy(Workbooks(sQue), Workbooks(sZie)) 'Namen kopieren
'Call SU_Namen_Kopieren(ThisWorkbook, Workbooks("xNamen_Kopie.xlsx"))
Call SU_Namen_Kopieren(Workbooks(sQue), Workbooks(sZie)) '16.07.12
Workbooks(sZie).Save
sTmp = "_Shapes kopieren - Zeit: " & Left(oT9(3, 3).Text, 5) & "_" & Left(Time, 5)
iZei = iZei + 1
oT9(iZei, 2) = sTmp
Application.StatusBar = sTmp
Call SU_Shapes_Delete_Ungroup_Copy(Workbooks(sQue), Workbooks(sZie))
iZei = iZei + 1
oT9(iZei, 2) = "Ende um"
oT9(iZei, 3) = Left(Time, 5)
Workbooks(sZie).Save
Workbooks(sQue).Activate
Workbooks(sQue).Close False 'OriginalDatei schliessen ohne zu speichern
ThisWorkbook.Save
Application.StatusBar = ""
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
'SU_Arbeitsmapppe_Zellenweise_kopieren()
' #############################################################################################
' ################################## U N T E R P R O G R A M M E ##############################
' #############################################################################################
Sub X_Test() 'Hier können die einzelnen Makros getestet werden
Dim x As Integer, j As Integer, sTmp As String, sQue As String, oQue As Object, sZie As String, oZie As Object
If Workbooks.Count > 1 Then 'Ist die Datei bereits offen?
For x = 1 To Workbooks.Count
sTmp = Workbooks(x).Name
If sTmp ThisWorkbook.Name And LCase(sTmp) "personal.xlsb" Then
sQue = sTmp
j = InStr(StrReverse(sQue), ".")
sZie = Left(sTmp, (Len(sTmp) - j)) & "_Neu" & Right(sTmp, j)
Exit For
End If
Next x
End If
If sQue = "" Then MsgBox "Es ist keine Source-Datei geöffnet - Abbruch!", vbExclamation: Exit Sub
If sZie = "" Then MsgBox "Es ist keine Ziel-Datei geöffnet - Abbruch!", vbExclamation: Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set oQue = Workbooks(sQue) '"_Offkalk Kaba exos-28.01.11.xlsm"
Set oZie = Workbooks(sZie) '"_Offkalk Kaba exos-28.01.11_Neu.xlsm"
Call SU_Tabellen_Struktur_Vergleichen(Workbooks(sQue), Workbooks(sZie))
For j = 1 To oQue.Sheets.Count
Call SU_Verbundene_Zellen_Merken_Entfernen(Workbooks(sQue), j)
Call SU_Zellen_Verbinden(oZie, j)
Call SU_Seitenformatierung(Workbooks(sQue), Workbooks(sZie), j)
Next j
Call SU_Names_Copy(Workbooks(sQue), Workbooks(sZie))
Call SU_Shapes_Delete_Ungroup_Copy(Workbooks(sQue), Workbooks(sZie))
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
'X_Test()
' #############################################################################################
' ################################## U N T E R P R O G R A M M E ##############################
' #############################################################################################
'Sub SU_Alle_Daten_Löschen() 'Tabellen löschen
'Dim x As Integer, ws As Worksheet
'Application.DisplayAlerts = False
'ThisWorkbook.Activate
'Tab999.Visible = xlSheetVisible
'For Each ws In Worksheets
' If ws.CodeName "Tab999" Then ws.Delete
'Next
'Application.DisplayAlerts = True
'End Sub
' #############################################################################################
Sub SU_Tabellen_Struktur_Vergleichen(oQue As Workbook, oZie As Workbook)
Dim iTab As Integer, j As Integer, k As Integer, x As Integer, sTmp As String
Dim oWS As Worksheet
iTab = oQue.Sheets.Count
'Set oZie = ThisWorkbook
' =============================================================================================
' Alle Tabellenblätter löschen, letztes Tabellenblatt auf Tab999 (Peter) umbenennen
Application.DisplayAlerts = False
oZie.Activate
For Each oWS In Worksheets
oWS.Visible = xlSheetVisible
If oWS.Name Sheets(1).Name Then oWS.Delete
Next
' ---------------------------------------------------------------------------------------------
' Tabellenblätter ergänzen, TabellenName und TabelleCodeName anpassen
iTab = oQue.Sheets.Count
If Sheets.Count
sTmp = Replace(Time(), ":", "")
oZie.Sheets(1).Name = sTmp 'Falls dieses Makro 2x läuft (gleiche Namen)
oZie.VBProject.VBComponents(Sheets(1).CodeName).Properties(5).Value = "T" & sTmp
For x = 1 To iTab
Sheets.Add after:=Sheets(Sheets.Count)
oZie.Sheets(Sheets.Count).Name = oQue.Sheets(x).Name
oZie.VBProject.VBComponents(Sheets(Sheets.Count).CodeName).Properties(5).Value = oQue.Sheets(x).CodeName
oZie.Sheets(x).Unprotect
oQue.Sheets(x).Unprotect
Next x
oZie.Sheets(1).Delete '1. Blatt wieder löschen
End If
Application.DisplayAlerts = True
End Sub
'SU_Tabellen_Struktur_Vergleichen()
' #############################################################################################
Sub X_Name_Kopieren()
Call SU_Namen_Kopieren(ThisWorkbook, Workbooks("xNamen_Kopie.xlsx"))
End Sub
Private Sub SU_Namen_Kopieren(xlObjQ As Object, xlObjZ As Object) '16.07.12 Herber (Ralf) - _
funktioniert
Dim oNameQ As Object, oNameZ As Object
On Error Resume Next
For Each oNameQ In xlObjQ.Names
Set oNameZ = xlObjZ.Names(oNameQ.Name)
If oNameZ Is Nothing Then Set oNameZ = xlObjZ.Names.Add(Name:=oNameQ.Name, RefersTo:=oNameQ. _
RefersTo)
oNameZ.RefersToR1C1 = oNameQ.RefersToR1C1
Set oNameZ = Nothing
Next oNameQ
Set oNameZ = Nothing
End Sub
'SU_Namen_Kopieren()
' #############################################################################################
Sub SU_Verbundene_Zellen_Merken_Entfernen(oWB As Workbook, iTab As Integer) 'oQue ohne .cells()
Dim iZeiAnz As Long, iSpaAnz As Integer, z As Long, s As Integer, j As Integer, k As Integer
Dim sTmp As String, oZie As Object, oQue As Object, c As Integer, r As Integer
Set oZie = ThisWorkbook.Sheets(Tab999.Name).Cells()
iZeiAnz = FU_ZeileO(oWB.Sheets(iTab), 1, 10)
iSpaAnz = FU_SpalteO(oWB.Sheets(iTab), 1, 15)
Set oQue = oWB.Sheets(iTab).Cells()
If iZeiAnz = 0 Or iSpaAnz = 0 Then Exit Sub
ThisWorkbook.Sheets(Tab999.Name).Columns(1).ClearContents
For z = 1 To iZeiAnz
For s = 1 To iSpaAnz
r = oQue(z, s).MergeArea.Rows.Count 'Anzahl verbundene Zeilen
c = oQue(z, s).MergeArea.Columns.Count 'Anzahl verbundene Spalten
If r > 1 Or c > 1 Then
sTmp = FU_SpaBez(s) & z & ":" & FU_SpaBez(s + c - 1) & z + r - 1
k = FU_ZeileO(ThisWorkbook.Sheets(Tab999.Name), 1) + 1
If k > 0 Then oZie(k, 1) = sTmp
Range(oQue(z, s), oQue(z + r - 1, s + c - 1)).MergeCells = False 'muss im Original aufgelöst werden, da es bei Folgezellen Fehler gibt
End If
Next s
Next z
End Sub
'SU_Verbundene_Zellen_Merken_Entfernen()
' #############################################################################################
Sub SU_Zellen_Verbinden(oZie As Workbook, iTab As Integer) 'in neuer Arbeitsmappe
Dim iZeiAnz As Long, z As Long
Dim sRng As String
oZie.Activate
Sheets(iTab).Activate
iZeiAnz = FU_ZeileO(ThisWorkbook.Sheets(Tab999.Name), 1)
If iZeiAnz = 0 Then Exit Sub
For z = 1 To iZeiAnz
sRng = ThisWorkbook.Sheets(Tab999.Name).Cells(z, 1)
oZie.Sheets(iTab).Range(sRng).MergeCells = True
Next z
End Sub
'SU_Zellen_Verbinden()
' #############################################################################################
Sub SU_Names_Copy(oQue As Workbook, oZie As Workbook) 'von Herber 07.03.11, oQue = OriginalDatei
Dim definedName As Object
Dim n As Long, Nc As Long
For Each definedName In oZie.Names 'bestehende Namen löschen
definedName.Delete
Next
Nc = oQue.Names.Count
If Nc > 0 Then
For n = 1 To Nc
oZie.Names.Add Name:=oQue.Names(n).Name, RefersTo:=oQue.Names(n).RefersTo
Next
End If
End Sub
'SU_Names_Copy()
' #############################################################################################
Sub SU_Shapes_Delete_Ungroup_Copy(oQue As Workbook, oZie As Workbook)
Dim oTab As Worksheet, oShp As Shape, j As Integer
' --------------------------------------------------------------------------------------------
'Löschen
oZie.Activate
For Each oTab In oZie.Worksheets
oTab.Visible = True
oTab.Unprotect
oTab.Cells.ClearOutline 'Gliederung aufheben
For Each oShp In oTab.Shapes
oShp.Delete
Next
Next oTab
Application.ScreenUpdating = False
' --------------------------------------------------------------------------------------------
'Ungroup und Copy
For Each oTab In oQue.Worksheets
oTab.Visible = True
oTab.Activate 'im Original anders
oTab.Unprotect
oTab.Cells.ClearOutline 'Gliederung aufheben
For j = 1 To 5 'Gruppierung aufheben, damit Namen übernommen werden (MehrfachGruppen)
For Each oShp In oTab.Shapes
If oShp.Type = msoGroup Then oShp.Ungroup
Next
Next j
' ------------------------------------------------------------------------------------------
For Each oShp In oTab.Shapes
'MsgBox j & ".) " & oShp.Name
'Wenn das Makro beim oShp.Copy mit einer Fehlermeldung aussteigt, dann kann über Msgbox oShp.Name der Name
'rausgefunden werden. So kann dieses Shape mit if left(oShp.Name, n) = "Name" then ausgeklammert oder
'mit oShp.Delete gelöscht werden.
If Left(oShp.Name, 7) "Comment" Then oShp.copy 'Comment xy ergeben Error 1004 (weiss nicht was für eine Grafik das ist)
With oZie.Worksheets(oTab.Index) 'Tabellenreihenfolge muss gleich sein
.Paste
With .Shapes(.Shapes.Count)
.Top = oShp.Top
.Left = oShp.Left
.Name = oShp.Name 'Shapes dürfen nicht in Gruppen sein
End With
End With
Next oShp
Next oTab
oZie.Activate
Application.ScreenUpdating = True
End Sub
'SU_Shapes_Delete_Ungroup_Copy_Neu()
' #############################################################################################
Sub SU_Seitenformatierung(oQue As Workbook, oZie As Workbook, iTab As Integer)
'Windows("_Offkalk Kaba exos-28.01.11.xlsm").Activate
oZie.Activate
Sheets(iTab).Activate
With oZie.Sheets(iTab).PageSetup
.PrintArea = oQue.Sheets(iTab).PageSetup.PrintArea
.PrintTitleRows = oQue.Sheets(iTab).PageSetup.PrintTitleRows
.PrintTitleColumns = oQue.Sheets(iTab).PageSetup.PrintTitleColumns
.LeftHeader = oQue.Sheets(iTab).PageSetup.LeftHeader
.CenterHeader = oQue.Sheets(iTab).PageSetup.CenterHeader
.RightHeader = oQue.Sheets(iTab).PageSetup.RightHeader
.LeftFooter = oQue.Sheets(iTab).PageSetup.LeftFooter
.CenterFooter = oQue.Sheets(iTab).PageSetup.CenterFooter
.RightFooter = oQue.Sheets(iTab).PageSetup.RightFooter
.LeftMargin = oQue.Sheets(iTab).PageSetup.LeftMargin
.RightMargin = oQue.Sheets(iTab).PageSetup.RightMargin
.TopMargin = oQue.Sheets(iTab).PageSetup.TopMargin
.BottomMargin = oQue.Sheets(iTab).PageSetup.BottomMargin
.HeaderMargin = oQue.Sheets(iTab).PageSetup.HeaderMargin
.FooterMargin = oQue.Sheets(iTab).PageSetup.FooterMargin
.PrintHeadings = oQue.Sheets(iTab).PageSetup.PrintHeadings
'.PrintGridlines = False
'.PrintComments = xlPrintNoComments
'.PrintQuality = 600
.CenterHorizontally = oQue.Sheets(iTab).PageSetup.CenterHorizontally
.CenterVertically = oQue.Sheets(iTab).PageSetup.CenterVertically
.Orientation = oQue.Sheets(iTab).PageSetup.Orientation
'.Draft = False
'.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
' .FitToPagesWide = 1
' .FitToPagesTall = 1
' .PrintErrors = xlPrintErrorsDisplayed
' .OddAndEvenPagesHeaderFooter = False
End With
End Sub
'SU_Seitenformatierung(
' #############################################################################################
' ############################### H I L F S - P R G R A M M E ###############################
' #############################################################################################
Sub dsfsd()
MsgBox FU_ZeileO(ThisWorkbook.Sheets(Tab999.Name), 1)
End Sub
Function FU_ZeileO(oTab As Object, iSpa As Integer, Optional iAnz As Integer)
' Aufruf: FU_Zeilen(Tabelle3, 2,1) - Zeilenzählen in der 2. Spalte der Tabelle3
Const iMax As Long = 50
Dim z As Long, iLee As Integer, n As Integer
' ---------------------------------------------------------------------------------------------
On Error Resume Next
If iSpa
' ---------------------------------------------------------------------------------------------
For n = 1 To (iAnz + 1)
iLee = 0
z = 1
Do While iLee
If Trim(oTab.Cells(z, iSpa + n - 1)) = "" Then
iLee = iLee + 1
Else
iLee = 0
End If
z = z + 1
Loop
If (z - iLee - 1) > FU_ZeileO Then FU_ZeileO = z - iLee - 1
Next n
End Function
' FU_ZeileO()
' #############################################################################################
Function FU_SpalteO(oTab As Object, iZei As Integer, Optional iAnz As Integer)
' Aufrufe: FU_SpalteO(Tab01, 1) - Spaltenzeilen in der 1. Zeile der Tabelle1
Const iMax As Long = 30
Dim s As Integer, iLee As Integer, n As Integer
' ---------------------------------------------------------------------------------------------
On Error Resume Next
If iZei
' ---------------------------------------------------------------------------------------------
For n = 1 To (iAnz + 1)
iLee = 0
s = 1
Do While iLee
If Trim(oTab.Cells(iZei + n - 1, s).Value) = "" Then
iLee = iLee + 1
Else
iLee = 0
End If
s = s + 1
Loop
If (s - iLee - 1) > FU_SpalteO Then FU_SpalteO = s - iLee - 1
Next n
End Function
' FU_SpalteO()
' #############################################################################################
Sub X_Spaltenbezug_AA_oder_27()
MsgBox "Spalte >BB" & FU_SpaBez("BB") & "
MsgBox "Spalten-Nr >27" & FU_SpaBez(27) & "
End Sub
' =============================================================================================
Function FU_SpaBez(sSPA As Variant) ' "A..ZZZ" oder 1...999
' Verwandelt alphabethische Spalte in numerische Spalte und umgekehrt
Const iABZ As Integer = 26
Dim s1 As String, s2 As String
Dim iSpa As Integer
' ---------------------------------------------------------------------------------------------
If Trim(sSPA) = "" Then FU_SpaBez = "0": Exit Function
If Trim(sSPA) = "0" Then FU_SpaBez = "": Exit Function
' ---------------------------------------------------------------------------------------------
If Val(sSPA) = 0 Then ' Buchstabe wird Zahl
sSPA = UCase(sSPA) ' In Grossbuchstaben verwandeln
If Len(sSPA) = 2 Then
FU_SpaBez = ((Asc(Left(sSPA, 1)) - 64) * iABZ) + (Asc(Right(sSPA, 1)) - 64)
Else
FU_SpaBez = Asc(sSPA) - 64
End If
Else ' Zahl wird Buchstabe
iSpa = Val(sSPA)
s1 = Chr(((iSpa - 1) \ iABZ) + 64) ' Ermitteln des 1. Zeichens "A?"
s2 = Chr(((iSpa - 1) Mod iABZ) + 1 + 64) ' Ermitteln der 2. Zeichens "?B" (Rest)
' -----------------------------------------------------------------------------------------
If iSpa
If iSpa > iABZ Then ' 2-stellig
FU_SpaBez = s1 & s2
Else
FU_SpaBez = s2
End If
End If
End Function
'FU_SpaBez()
' #############################################################################################
Function FU_Ordner_Vorhanden(sFolder As String) As Boolean 'Wahr=vorhanden, Falsch=nicht vorhanden
Dim sOld As String
sOld = CurDir
On Error Resume Next
ChDrive Left(sFolder, 1)
ChDir sFolder
If Err = 0 Then FU_Ordner_Vorhanden = True
On Error GoTo 0
ChDrive Left(sOld, 1)
ChDir sOld
End Function
' #############################################################################################
Public Function FormelText(r) As String
' A1="=Hallo Peter" > Aufruf =FormelText(A1) > "="Hallo Peter"" > "=FormelText(A1)"
Application.Volatile
If Left(r.Formula, 1) = "=" Then FormelText = r.Formula Else FormelText = r.Value ' _
englische Ausgabe
'If Left(r.Formula, 1) = "=" Then FormelText = Right(r.Value, Len(r.Value) - 1) Else r. _
Value
End Function
' #############################################################################################
' ##################################### E N D E ##########################################
' #############################################################################################