Übernahme der Werte aus grün gefärbten Zellen
12.05.2025 18:53:00
Lara835
Es gibt eine Master-Datei und eine Input-Datei. Die Master-Datei enthält mehr Spalten als die Input-Datei. Ich habe aus der Tabelle in der Master-Datei eine intelligente Tabelle gemacht und in der Input-Datei diese Datei abgerufen (via Daten -> Daten abrufen -> aus Datei -> ... -> die intelligente Tabelle aus der Master-Datei ausgewählt und nur die Spalten, die ich benötige ausgewählt).
Da die Kollegen, die die Input-Datei ausfüllen sollen, nicht erst Werte eintragen, wenn diese feststehen, sondern auch Werte eintragen, die noch besprochen werden müssen, möchte ich es so handhaben, dass sie immer dann, wenn die Werte final sind, diese Zelle/n grün hinterlegen sollen. Erst dann, wenn die Zellen grün hinterlegt sind, möchte ich, dass die Werte in die Master-Datei übernommen werden.
Die Nummer der Zeile ist die selbe in Master- und Input-Datei. Die Spaltenbezeichnung nach Excel (A, B, C) kann aber nicht genommen werden, da ich in der Input-Datei nur manche der Spalten übernommen habe und falls die Kollegen Spalten hinzufügen möchte ich nicht, dass es nicht mehr funktioniert. Hier können aber bestimmt die Spaltenbezeichnungen der intelligenten Tabellen genutzt werden, da diese übereinstimmen? Da ich aktuell nur herumteste hat die Spalte, an der ich es testen möchte, keinen richtigen Namen, sondern heißt nur "Spalte16".
Ich habe bereits viel recherchiert, komme aber nicht weiter. Ich versuche mich das 1. Mal an einem Makro, also seid bitte nachsichtig mit den tausend Fehlern, die sich hier sicher eingeschlichen haben. Ich habe als Grundlage den Code genommen, der hier für ein anderes Problem geschrieben wurde: https://administrator.de/forum/excel-makro-zum-einfuegen-von-daten-aus-anderen-excel-dateien-254018.html - Ich habe aus A immer M für Master und aus B I für Input gemacht. Im Private Sub "GetValues" verstehe ich nicht, was dort passiert und wusste daher nicht, wo ich meine Tabellenspalte eintragen kann als Zielspalte fürs Einfügen des Wertes.
Die Fehlermeldung, die ich aktuell bekomme ist 76 bei "ChDir ThisWorkbook.Path", die Dateien liegen beide auf dem Sharepoint - ich glaube, dass ChDir dann nicht genutzt werden kann?
Option Explicit
Private Const RowStartM = 10 'Daten ab Zeile 10 ; wird nicht verwendet - kann weg?
Private Const ColDataM = "B:F" 'Daten(Master): B:F ; wird nicht verwendet - kann weg?
Private Const ColDataI = "D,B,E,D" 'Daten(Input): D->B, E->D ; wird nicht verwendet - kann weg?
Public Sub CheckForGreen()
Dim oWkbI As Workbook
Dim oWksM As Worksheet, oWksI As Worksheet
Dim sFileI As Variant
Dim oCell As Range, oCells As Range, oFound As Range
Dim TabelleM As ListObject, TabelleI As ListObject
'Wahlweise einen anderen Ordnerpfad in Form "X:\Folder" angeben; Fehlermeldung 76 - Datei liegt auf Sharepoint. Wahrscheinlich ChDir dann falsch?
ChDir ThisWorkbook.Path
'Import-Dateiauswahl(Input) *.xlsx-Dateien, bei Bedarf entsprechend anpassen
sFileI = Application.GetOpenFilename("Excel-Datei(Input) (*.xlsx), *.xlsx")
If sFileI = False Then
MsgBox "Dateiauswahl unvollständig!", vbInformation, "Dateiauswahl . . ."
Exit Sub
End If
Set oWkbI = GetObject(sFileI) 'Set/Open Datei(Input)
Set TabelleM = ActiveSheet.ListObjects("Tabelle5") 'Set intelligente Tabelle von MasterSheet
Set TabelleI = sFileI.Sheets(1).ListObjects("Tabelle5__2") 'Set intelligente Tabelle von InputSheet
Set oWksM = ThisWorkbook.Sheets(1) 'Set Workbook(Master)-Sheet1
Set oWksI = oWkbI.Sheets(1) 'Set Workbook(Input)-Sheet1
With oWksM 'Daten-Bereich festlegen; brauche ich diesen Schritt überhaupt? Im Original Datenvergleich, hier nicht
Set oCells = .Range(TabelleM.DataBodyRange.Columns("Spalte16"))
End With
Application.ScreenUpdating = False
For Each oCell In oCells 'Alle Zellen(oCells) durchlaufen
With TabelleI.DataBodyRange.Columns("Spalte16") 'Datei(Input)durchsuchen nach Hintergrundfarbe grün
Set oFound = .Find(oCell.Interior.Color = RGB(146, 208, 80)) 'hier müsste oCell eigentlich in der Input-Datei sein? Ginge dann oben nur "DataBodyRange.Columns("Spalte16")"? - gibt Fehlermeldung
End With
If Not oFound Is Nothing Then 'Datei(B): Wenn gefunden Daten kopieren
Call GetValues(oWksM, oWksI, TabelleI.DataBodyRange.Columns("Spalte16"), oCell.Row, oFound.Row)
End If
Next
oWkbI.Close False 'Datei(Input) schließen (speichern=False)
Application.ScreenUpdating = True
MsgBox "Fertig!", vbInformation, "Datenimport . . ."
End Sub
Private Sub GetValues(ByRef oWksM, ByRef oWksX, ByRef sCols, ByVal iRowA As Long, ByVal iRowX As Long)
Dim aColumns As Variant, i As Integer
aColumns = Split(sCols, ",")
With oWksX.Rows(iRowX)
For i = 0 To UBound(aColumns) Step 2
oWksM.Cells(iRowA, aColumns(i + 1)).Value = .Columns(aColumns(i)).Value
'(TabelleM.DataBodyRange.Columns("Spalte16")) -> wo muss das hin? Zeile die selbe wie im input-file, spalte muss diese hier sein
Next
End With
End Sub
Es wäre super lieb, wenn ihr mir helfen könntet!
LG Lara
Anzeige