Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1412to1416
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Identifier für kopierte Zeilen aus unterschiedlich

Identifier für kopierte Zeilen aus unterschiedlich
05.03.2015 10:11:01
Dennis
Hallo alle miteinander,
ich hoffe ihr könnt mir helfen, ich bin noch ziemlich neu in dem Bereich vba unterwegs
Folgendes Problem:
Ich führe aus sehr vielen Excel Dateien spezifische Bereiche in ein neues Excel FIle (in dem auch das Makro läuft) zusammen.
Jetzt muss ich aber zusätzlich zu den kopierten Zeilen einen Identifier einfügen(vorzugsweise in die erste Spalte), der mir wiedergibt, aus welcher datei (xyfile.name) diese kopierten Zeilen stammen.
Der Import funktioniert einwandfrei jedoch schaffe ich das mit dem Identifier nicht.
Der aus einem

Private Sub aufgerufene sub (zwecks loop für die verschiedenen dateien) sieht folgendermaßen  _
aus, und den kritischen Bereich habe ich mit 'HIER FANGEN DIE PROBLEME AN' markiert:
Sub Upload_Risk(Allfile As Workbook, PRJFile As Workbook)
' Upload actual  report data from PRJ work file to consolidation file, sheet "INT"
Dim MaxLine As Integer
Dim MaxFillLine As Integer
Dim FirstEmptyLine As Integer
Dim NewLine As Integer
Dim lngLetzte As Long
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 6)), Cells(Rows.Count, 6).End(xlUp).Row, Rows. _
Count)
'Upload takes some time, calculation and screen updating is suspended during upload of data
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'Identify first empty line in consolidation file, sheet "INT"
Allfile.Activate
Sheets("INT").Select
FirstEmptyLine = 1
While Cells(FirstEmptyLine, "H").Text  ""
FirstEmptyLine = FirstEmptyLine + 1
Wend
PRJFile.Activate
Sheets("RISKS").Select
'Identify missing Risks
MaxLine = Cells(Rows.Count, "B").End(xlUp).Row
If MaxLine  ""
NewLine = NewLine + 1
HIER FANGEN DIE PROBLEME AN
Dim Reihe As Integer
Reihe = NewLine
With ActiveWorkbook.Worksheets("INT")
Do Until .Cells(Reihe, "H") = vbNullString
If .Cells(Reihe, "H")  "" Then
.Cells(Reihe, "A") = PRJFile.Name
End If
Reihe = Reihe + 1
Loop
End With
Wend
'Calculation and screen updating is resumed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Im Prinzip soll das Makro in dem Moment, in dem es auch die Zeilen kopiert in das Konsolidierungsfile die Identifier schreieben
Ich hoffe Euer Fundus an Wissen hilft mir hier weiter.
Viele Grüße und Danke schon mal im Voraus
Dennis

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Identifier für kopierte Zeilen
05.03.2015 11:04:53
EtoPHG
Hallo Dennis,
Deine Probleme im Code fangen schon viel früher an und nicht erst beim 'kritischen Bereich'.
Die Variable lngLetzte wird aufgrund der Daten des zum Makro-Laufzeitpunkt gerade aktiven Arbeitsblatts bestimmt, ist das richtig und wie verhinderst du z.B. das der Code bei einem aktiven Diagrammblatt aktiviert wird. Letzteres würde unweigerlich zu einem Codeabsturz führen.
Zeilen- und Spaltenindex sollten grundsätzlich Long und nicht Integer dimensioniert werden.
    Dim MaxFillLine As Long
Dim FirstEmptyLine As Long
...etc.

.Activate und .Select sind Methoden, die in VBA äussert selten gebraucht werden und in den meisten Fällen zu kontraproduktiven Resultaten führt. Alle Bereichsreferenzierungen (Range/Cells/Rows etc.) sollten eindeutig gesetzt werden. Darum empfehle ich folgendes System zu verwenden:
   Dim wsQ As WorkSheet, wsZ As Worksheet   ' Quelle- und Zielblatt
Set wsQ = PRJFile.Worksheets("RISKS")
Set wsZ = Allfile.Worksheets("INT") 

damit kannst du z.B. schreiben:
    MaxLine = wsQ.Cells(wsQ.Rows.Count, 2).End(xlUp).Row

(der übrige Code mit der Msgbox wird übrigens nie durchlaufen, da es keine Zeilnummern Dein Copy kann direkt (ohne Activate/Select) ausgeführt werden:
    wsQ.Range("A7:P" & lngLetzte).Copy wsZ.Cells(NewLine, 3)
With wsZ.Range(wsZ.Cells(NewLine,3),wsZ.Cells(wsZ.Rows.Count,3).End(xlup))
.Value = .Value
End with

Du kannst einen Wert auch in einem Rutsch in einen Zellbereich schreiben, z.b. so:
wsZ.Range(wsZ.Cells(NewLine,1),wsZ.Cells(wsZ.Rows.Count,1).End(xlup)) = PRJFile.Name    
Gruess Hansueli

Anzeige
AW: Identifier für kopierte Zeilen
06.03.2015 12:42:23
Dennis
Hallo Hansueli,
danke erst mal für Deine Antwort.
Leider hat sich hieraus für mich kein Ergebnis in Bezug auf den Identifier gegeben.
Um Deine Fragen zu Beantworten und weiterhin näher zu bringen, wie das gesamte Makro Aufgebaut ist, hier auch noch mal der Privat sub aus dem der sub aufgerufen wird.
Teile des subs habe ich schon nach Deinen VOrgaben verbessert, jedoch die Bereich Deiner Verbesserung, die bei dem Makro nicht funktionierten ausgelassen.
Hier der Private Sub:
Dim PRJFile As Workbook
Dim Allfile As Workbook
Dim PRJFiles(1 To 3) As String
Dim sPath As String
Dim PRJ As String
Dim WBopen As Boolean '
Set Allfile = ThisWorkbook
On Error GoTo ErrorRoutine
PRJFiles(1) = "T+_PRJ_Report_FF-SFI" & ".xlsm"
PRJFiles(2) = "T+_PRJ_Report_FF-SFP" & ".xlsm"
PRJFiles(3) = "T+_PRJ_Report_STERI" & ".xlsm"
'Upload takes some time, calculation and screen updating is suspended during upload of data
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'Upload PRJ data
For i = 1 To 3
sPath = ThisWorkbook.Path & "\" & PRJFiles(i)
WBopen = False
'Check if PRJ work file is already open
If Not IsWBOpen(PRJFiles(i)) Then
'If TA work file is not open check if file is available in folder and if yes: open file
If Dir(sPath)  "" Then
Workbooks.Open sPath
Else
'If PRJ work file is not available display warning and ask if upload shall be continued
MsgBox "PRJ file " & PRJFiles(i) & " is missing"
ContinueUpload = _
MsgBox("Do you want to continue the upload?", _
vbYesNo, "Continue upload?")
If ContinueUpload = vbNo Then
Exit For
End If
End If
Else
'PRJ file was already open, therefore it will not be closed after data upload but stay  _
open
WBopen = True
End If
If IsWBOpen(PRJFiles(i)) Then
'Upload PRJ file data
Set PRJFile = Workbooks(PRJFiles(i))
PRJFile.Activate
Call Upload_Risk(Allfile, PRJFile)
'If PRJ work file was opend by macro it will be closed again (w/o saving)
If Not WBopen Then Workbooks(PRJFiles(i)).Close False
End If
Next i
Allfile.Activate
Sheets("PRJ").Select
Application.Calculation = xlCalculationAutomatic
ErrorRoutine:
'Calculation and screen updating is resumed
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "Import of project risks completed"
End Sub
Function IsWBOpen(wbname As String) As Boolean
'Open workbook.
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(wbname)
IsWBOpen = Not wb Is Nothing
End Function
und hier der angepasste sub, leider immer noch ohne eine Möglichkeit einen Identifier zu setzen, der sich auf PRJFile (i) bezieht:
Sub Upload_Risk(Allfile As Workbook, PRJFile As Workbook)
' Upload actual  report data from PRJ work file to consolidation file, sheet "INT"
Dim MaxLine As Long
Dim MaxFillLine As Long
Dim FirstEmptyLine As Long
Dim NewLine As Long
' Quelle- und Zielblatt
Dim wsQ As Worksheet, wsZ As Worksheet
Set wsQ = PRJFile.Worksheets("RISKS")
Set wsZ = Allfile.Worksheets("INT")
Dim lngLetzte As Long
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 6)), Cells(Rows.Count, 6).End(xlUp).Row, Rows. _
Count)
'Upload takes some time, calculation and screen updating is suspended during upload of data
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'Identify first empty line in consolidation file, sheet "INT"
Allfile.Activate
Sheets("INT").Select
FirstEmptyLine = 1
While Cells(FirstEmptyLine, "H").Text  ""
FirstEmptyLine = FirstEmptyLine + 1
Wend
'Identify missing Risks
MaxLine = wsQ.Cells(wsQ.Rows.Count, "B").End(xlUp).Row
If MaxLine  ""
NewLine = NewLine + 1
Dim Reihe As Integer
Reihe = NewLine
With ActiveWorkbook.Worksheets("INT")
Do Until .Cells(Reihe, "H") = vbNullString
If .Cells(Reihe, "H")  "" Then
.Cells(Reihe, "A") = PRJFile.Name
End If
Reihe = Reihe + 1
Loop
End With
Wend
'Calculation and screen updating is resumed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Ich hoffe das hilft.
Danke schon mal und Grüße

Anzeige
AW: Identifier für kopierte Zeilen
06.03.2015 16:12:15
EtoPHG
Hallo Dennis
Schwierig dein Gewurstel auseinander zu dividieren, aber m.E. sollte es so laufen:
Sub Upload_Risk(Allfile As Workbook, PRJFile As Workbook)
' Upload actual  report data from PRJ work file to consolidation file, sheet "INT"
Dim sMsg As String
Dim lRowNextZ As Long
Dim lRowLastQ As Long
' Quelle- und Zielblatt
Dim wsQ As Worksheet, wsZ As Worksheet
Set wsQ = PRJFile.Worksheets("RISKS")
Set wsZ = Allfile.Worksheets("INT")
Application.ScreenUpdating = False
Application.EnableEvents = False
lRowNextZ = wsZ.Cells(wsZ.Rows.Count, 8).End(xlUp).Row + 1
lRowLastQ = wsQ.Cells(wsQ.Rows.Count, 6).End(xlUp).Row
With wsQ
lRowLastQ = .Cells(.Rows.Count, 2).End(xlUp).Row
If lRowLastQ 
Gruess Hansueli
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige