aus irgend einem Grund ist mein Beitrg nicht mehr auffindbar. Daher nun ein zweiter Versuch.
https://www.herber.de/cgi-bin/forum/call_forum.pl
DANKE!!!
Sandra
Sub Test_01_06_2011()
Dim oXlSM As Workbook, oXML As Workbook
Dim nIndexXLSM, nIndexXLM, MaxRow As Long, nIndex As Long
Dim rngXLSM As Range, rngXML As Range, ArrayXLSM
Dim strFehler As String
Dim ArrayQuelle, ArrayZiel
Const sListZeichen$ = " "
'hier stehen die Überschriften, nach denen gesucht wird
'Wichtig! Die Reihenfolge muss bei beiden identisch sein
ArrayQuelle = Array("Betrifft", "verortete Zustandsbeschreibung", "Mangelart", "Vertragsart",
"Gewerke-gruppe", "Gewerk", "Bauabschnitt", "Geschoss", "Nutzung", "Bereich", "Raum", "Achse",
"Foto", "Frist", "Nachfrist", "letzte Nachfrist", "Auftragnehmer", "strittig", " _
sicherheitsrelevant", "betriebsrelevant", "optisch", "Restleistung", "Anspruch unsicher")
ArrayZiel = Array("betrifft", "Zustandsbeschreibung", "Mangelart", "Vertragsart", " _
Gewerkegruppe",
"Gewerk", "Bauabschnitt", "Geschoss", "Nutzung", "Bereich", "Raum", "Achse", "Foto", "Frist",
"Nachfrist", "letzte Nachfrist", "Auftragnehmer", "strittig", "sicherheitsrelevant", " _
betriebsrelevant", "optisch", "Restleistung", "Anspruch unsicher")
'hier wird festgelegt welche Datei geöffnet werden soll und wo diese gespeichert ist
Set oXML = Workbooks.Open(Filename:= _
"\\xxx.xxx.xx.x\?-?\Projekte\2009\09-02 ?\0000 Intern\" & _
"0000 MUSTER\? VORLAGE Zustandsbeschreibung.xml")
Set oXlSM = ThisWorkbook 'ThisWorkbook = die xlsm-Datei, in der dieser Code steht
For nIndex = LBound(ArrayQuelle) To UBound(ArrayQuelle)
With oXlSM.Sheets("Mängel vor der Abnahme") 'Name des Tabellenblattes, welches in der xlsm- _
_
_
Datei benutzt wird
nIndexXLSM = Application.Match(ArrayQuelle(nIndex), .Rows(2), 0) 'sucht in der Zeile 2 _
_
_
nach den Spaltenbeschriftungen
If IsNumeric(nIndexXLSM) Then
MaxRow = .Cells(.Rows.Count, nIndexXLSM).End(xlUp).Row 'letzte Zeile in Spalte
Set rngXLSM = .Range(.Cells(3, nIndexXLSM), .Cells(MaxRow, nIndexXLSM))
If MaxRow > 3 Then
ArrayXLSM = rngXLSM
ElseIf MaxRow = 3 Then
ArrayXLSM = rngXLSM.Resize(, 2)
ReDim Preserve ArrayXLSM(1 To UBound(ArrayXLSM), 1 To 1)
Else
'Fehlermeldung die ausgegeben wird, wenn in einer der festgelegten Spaltenü _
berschrift der xlsm-Datei keine Daten gefunden werden konnten
strFehler = strFehler & sListZeichen & "In Spalte '" & _
ArrayQuelle(nIndex) & "' wurden keine Daten gefunden" & vbCr
End If
Else
'Fehlermeldung die ausgegeben wird, wenn eine festgelegte Spaltenüberschrift nicht _
_
_
in der xlsm-Datei gefunden werden konnte
strFehler = strFehler & sListZeichen & "Die Spalte'" & _
ArrayQuelle(nIndex) & "' wurde nicht in der Quell-Datei gefunden" & _
vbCr
End If
End With
If IsArray(ArrayXLSM) Then
With oXML.Sheets("neue Zustandsbeschreibungen") 'Name des Tabellenblattes, welches in _
_
_
der xml-Datei benutzt wird
nIndexXML = Application.Match(ArrayZiel(nIndex), .Rows(18), 0) 'sucht in der Zeile _
_
_
18 nach den Spaltenbeschriftungen
If IsNumeric(nIndexXLM) Then
'alle Inhalte der Zellen ab Zeile 19 werden für neue Daten gelöscht
.Range(.Cells(19, nIndexXML), .Cells(.Rows.Count, nIndexXML)).ClearContents
Set rngXLM = .Cells(19, nIndexXML) 'erste Einfügezelle
rngXLM.Resize(UBound(ArrayXLSM), 1) = ArrayXLSM 'Daten aus Array einfügen
Else
strFehler = strFehler & sListZeichen & "Die Spalte'" & _
ArrayZiel(nIndex) & "' wurde nicht in der Ziel-Datei gefunden" & _
vbCr
End If
End With
End If
ArrayXLSM = Empty
Next nIndex
If strFehler "" Then
MsgBox Left$(strFehler, Len(strFehler) - 1), vbExclamation, "Achtung!!! Spalten ohne Inhalt! _
_
_
End If
'speichern der xlm-Datei
ActiveWorkbook.SaveAs Filename:="\\xxx.xxx.xx.x\?\Projekte\2009\09-02 ?\6000 _
_
_
Rohbau\6110 GU ?\Dokumentation\" & _
Format(Date, "yymmdd") & " ? Zustandsbeschreibung " & Format(Time, "hh.mm") & " Uhr.xml"
'Leerzeilen werden gelöscht wenn A und B leer
Dim Sh_neue_Zustandsbeschreibungen As Worksheet
Dim iCalc As Long
On Error GoTo ErrExit
Set Sh_neue_Zustandsbeschreibungen = Sheets("neue Zustandsbeschreibungen") 'hier wird das _
Tabellenblatt beschrieben, wo die Leerzeilen gelöscht werden sollen
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
With Sh_neue_Zustandsbeschreibungen
.Unprotect 'hier erfolgt die Abschaltung des Blattschutzes
With .UsedRange.Columns(.UsedRange.Columns.Count).Offset(0, 1)
.FormulaR1C1 = "=IF(AND(ROW()>18,RC1&RC2=""""),TRUE(),ROW())"
Sh_neue_Zustandsbeschreibungen.UsedRange.Sort .Cells(1, 1), xlAscending, , , , , , xlNo
On Error Resume Next
.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
On Error GoTo ErrExit
.EntireColumn.Delete
End With
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
:=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
AllowUsingPivotTables:=True
End With
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With
Set Sh_neue_Zustandsbeschreibungen = Nothing
End Sub