AW: Funkion in VBA aktualisiert sich nicht automatisch
01.08.2016 14:07:42
Juliane
Hallo,
ich habe 2 andere Makros auf dem Blatt, die sind tlw. nur leider recht umfangreich (und leider klappt das mit dem Kopieren hierher nicht so gut):
Makro 1
Sub Erstausfüllung()
With Sheets("Reiter 2 Liste MP-O gefiltert")
.Range(Replace("A6:B#,D6:E#", "#", .Range("B" & .Rows.Count).End(xlUp).Row)).Copy
Sheets("MP_Punkte").Range("B12").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Range(Replace("J6:J#", "#", .Range("B" & .Rows.Count).End(xlUp).Row)).Copy
Sheets("MP_Punkte").Range("F12").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("MP_Punkte").Range("F12").PasteSpecial Paste:=xlPasteFormats
End With
Application.CutCopyMode = False
End Sub
Makro 2:
Public Sub main()
Dim dataRangeOriginal As Range
Dim dataRangeDestination As Range
Dim identifier1 As String
Dim identifier2 As String
Dim c1 As Range
Dim c2 As Range
Dim lastLine As Integer
Dim datasetFound As Boolean
'Intiiere die Variablen
Set dataRangeOriginal = ThisWorkbook.Worksheets(mdl_001_Constants.Original_Worksheet).Range( _
mdl_001_Constants.Relevant_Column_Vorhaben & mdl_001_Constants.First_Line_Original_Worksheet & ":" & mdl_001_Constants.Relevant_Column_Vorhaben & getLastLine(mdl_001_Constants.Original_Worksheet, mdl_001_Constants.Relevant_Column_Titel))
Set dataRangeDestination = ThisWorkbook.Worksheets(mdl_001_Constants.Destination_Worksheet). _
Range(mdl_001_Constants.Relevant_Column_Titel & mdl_001_Constants.First_Line_Destination_Worksheet & ":" & mdl_001_Constants.Relevant_Column_Titel & getLastLine(mdl_001_Constants.Destination_Worksheet, mdl_001_Constants.Relevant_Column_Titel))
Application.ScreenUpdating = False
For Each c1 In dataRangeOriginal.Cells
datasetFound = False
identifier1 = c1.Value & ThisWorkbook.Worksheets(mdl_001_Constants.Original_Worksheet). _
Cells(c1.Row, Col_Num("D")).Value
For Each c2 In dataRangeDestination.Cells
identifier2 = c2.Value & ThisWorkbook.Worksheets(mdl_001_Constants. _
Destination_Worksheet).Cells(c2.Row, Col_Num("D")).Value
If (True = compareDatasets(identifier1, identifier2)) Then
Call copyDataWF(mdl_001_Constants.Original_Worksheet, mdl_001_Constants. _
Destination_Worksheet, mdl_001_Constants.Relevant_Column_Status, c1.Row, mdl_001_Constants.Relevant_Column_StatusDest, c2.Row)
datasetFound = True
Exit For
End If
Next c2
If (Not datasetFound) Then
lastLine = getLastLine(mdl_001_Constants.Destination_Worksheet, mdl_001_Constants. _
Relevant_Column_VorhabenDest) + 1
Call copyData(mdl_001_Constants.Original_Worksheet, mdl_001_Constants. _
Destination_Worksheet, mdl_001_Constants.Relevant_Column_Vorhaben, c1.Row, mdl_001_Constants.Relevant_Column_VorhabenDest, lastLine)
Call copyData(mdl_001_Constants.Original_Worksheet, mdl_001_Constants. _
Destination_Worksheet, mdl_001_Constants.Relevant_Column_Titel, c1.Row, mdl_001_Constants.Relevant_Column_TitelDest, lastLine)
Call copyData(mdl_001_Constants.Original_Worksheet, mdl_001_Constants. _
Destination_Worksheet, mdl_001_Constants.Relevant_Column_Fahrzeugprojekt, c1.Row, mdl_001_Constants.Relevant_Column_Fahrzeugprojekt, lastLine)
Call copyData(mdl_001_Constants.Original_Worksheet, mdl_001_Constants. _
Destination_Worksheet, mdl_001_Constants.Relevant_Column_FG, c1.Row, mdl_001_Constants.Relevant_Column_FG, lastLine)
Call copyDataWF(mdl_001_Constants.Original_Worksheet, mdl_001_Constants. _
Destination_Worksheet, mdl_001_Constants.Relevant_Column_Status, c1.Row, mdl_001_Constants.Relevant_Column_StatusDest, lastLine)
End If
Next c1
Application.ScreenUpdating = True
End Sub
'Kopiere die Daten (ohne Formate)
Private Sub copyData(originalWorksheetName As String, destWorksheetName As String, srcColumn As _
String, srcLine As Integer, destColumn As String, destLine As Integer)
ThisWorkbook.Worksheets(originalWorksheetName).Range(srcColumn & srcLine).Copy
With ThisWorkbook.Worksheets(destWorksheetName)
.Range(destColumn & destLine).PasteSpecial Paste:=xlPasteValues
End With
End Sub
'Kopiere die Daten (mit Formate)
Private Sub copyDataWF(originalWorksheetName As String, destWorksheetName As String, srcColumn _
As String, srcLine As Integer, destColumn As String, destLine As Integer)
ThisWorkbook.Worksheets(originalWorksheetName).Range(srcColumn & srcLine).Copy
With ThisWorkbook.Worksheets(destWorksheetName)
.Range(destColumn & destLine).PasteSpecial Paste:=xlPasteValues
.Range(destColumn & destLine).PasteSpecial Paste:=xlPasteFormats
End With
End Sub
'Vergleiche die Datensätze nach Wert
Private Function compareDatasets(identifier1 As String, identifier2 As String) As Boolean
If (0 = StrComp(identifier1, identifier2, vbTextCompare)) Then
compareDatasets = True
Else
compareDatasets = False
End If
End Function
'Ermittle die letzte ungefüllte Spalte des Reiters
Private Function getLastColumn(worksheetName As String, numberOfLine As Integer) As String
With ThisWorkbook.Worksheets(worksheetName)
getLastColumn = Col_Letter(.Cells(numberOfLine, .Columns.Count).End(xlToLeft).Column + _
1)
End With
End Function
'Ermittle die erste Zeile des Reiters
Private Function getFirstLine(worksheetName As String, columnName As String) As String
With ThisWorkbook.Worksheets(worksheetName)
getFirstLine = .Cells(1, columnName).End(xlDown).Row
End With
End Function
'Ermittle die letzte Zeile des Reiters
Private Function getLastLine(worksheetName As String, columnName As String) As String
With ThisWorkbook.Worksheets(worksheetName)
getLastLine = .Cells(.Rows.Count, columnName).End(xlUp).Row
End With
End Function
Function Col_Num(ByVal sColLetter As String) As Long
Col_Num = ActiveWorkbook.Worksheets(1).Columns(sColLetter).Column
End Function