War keine böse Absicht - Werte kopieren die Zweite
03.06.2011 10:46:52
Sandra
Hallo Hajo,
ich dachte, es handelt sich um den Link zu meinem Beitrag, der nicht mehr in der Liste angezeigt wird.
Da war nämlich eine Menge Text mit Bildern. Einfach rauskopieren geht da ja dann nicht, oder?
Ich versuche es hier mal:
Hallo Sepp,
dass klappt super! 1.000-Dank!!!
Jetzt habe ich aber ein neues Problem. Meine Kollegen haben die Quelldatei überarbeitet. Nun habe ich im
aktuellen Stand, aber auch mal wieder ein Problem.
In der Quelldatei stehen Formeln um bestimmte Zellen automatisch auszufüllen.
Beim kopieren der Daten in die xml-Datei übernimmt er diese. Also Zeilen, die komplett ohne Inhalt sind,
die bleiben auch leer. Ist aber eine Zeile zum Teil ausgefüllt, dann taucht beim kopierten Text immer dort
eine 0 auf, wo in der Quelldatei eine Formel steht die aber nichts ermittelt hat.
Kannst Du mir folgen?
Hier mal zur Veranschaulichung ein paar Screenshots:
Hier kannst Du sehen, dass Zelle B10 (in der Quelldatei) leer ist. In wirklichkeit steht dort eine Formel drin.
=WENN(ISTFEHLER(SVERWEIS(A10;_Daten!$A$2:$D$226;2;FALSCH));"";SVERWEIS(A10;_Daten!$A$2:$D$226;2; FALSCH))
In der Zieldatei taucht nun eine 0 auf.
Wenn ich aber als Beispiel mal die Zeile 16 der Quelldatei nehme (das ist die erste Zeile, die nicht mehr
ausgefüllt ist), dann passiert das nicht in der Zieldatei. :(
Hast Du eine Idee?
Hier mal der Code (leicht "verschlüsselt").
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
Und dann habe ich noch ein weiteres Problem. Eigentlich eine Ergänzung. Aber die erörter ich vielleicht später!?
Lieben Gruß
und vielen lieben Dank!
Sandra
