|
Guten Tag zusammen,
ich kenne mich leider nicht sehr gut aus mit VBA und werde über Eure Unterstützung sehr Dankbar sein.
Problem:
Es handelt sich um eine Excel-Datei von Jahr 2017, der jetzt aktualisiert werden soll auf 2018. Die Excel Datei beinhaltet drei Tabellenblätter inkl. Pivot-Funktion. In der ersten Tabellenblatt warden Daten manuel eingefügt und anhand Pivot dann die Datei aktualisert.
Wie kann ich die Datei aktualisieren?
Die Datei wurde mit folgende Macros erstellt:
Modul 1:
Sub AbsoluteBezuege()
'
' AbsoluteBezuege Makro
'
' Tastenkombination: Strg+d
'
Dim Zelle As Range
For Each Zelle In Selection
If Zelle.HasFormula = True Then
Zelle.Formula = Application.ConvertFormula(Zelle.Formula, xlA1, , xlAbsolute)
'Zelle.Formula = Application.ConvertFormula( _
'Zelle.Formula, xlA1, xlA1, xlRelative, Zelle)
End If
Next Zelle
End Sub
Module 2:
' This function is written to compare reported consumptions and invoices
' in Overview worksheets.
' Each two corresponding cells in consumption and invoice tables have been
' compared.
' If they be matched, the color of cells will be set to Green, otherwise yellow
Modul 3:
Sub Paste_Invoice()
'
' Paste_Invoice Makro
'
' Tastenkombination: Strg+i
'
' Unter Extras, Verweise muss dieser Verweis gesetzt werden
' "Microsoft Forms 2.0 Object Library"
Dim InvoiceData As DataObject
Dim Page2 As Variant
Dim InvoiceTable As Variant
Dim InvoiceNo As String
Dim Row As Variant
Dim i As Integer
Dim blnError_PasteData
blnError_PasteData = False
'Get Data from Clipboard
Set InvoiceData = New DataObject
InvoiceData.GetFromClipboard
'Check if keywords for splitting are in string
If InStr(InvoiceData.GetText, "ANNEXURE") < 1 Or InStr(InvoiceData.GetText, "SUM") < 1 Then
MsgBox "Please make sure you copied the entire invoice document, including the words 'ANNEXURE' and 'SUM'."
Exit Sub
End If
'Split DataString, extract Invoice No and table with invoice items
Page2 = Split(InvoiceData.GetText(), "ANNEXURE")(1)
'Check if keywords for splitting are in string and extract page 2
If InStr(Page2, "Invoice No:") < 1 Or InStr(InvoiceData.GetText, "Job Type") < 1 Then
MsgBox "An Error occured, keywords 'Invoice No:' and 'Job Type' missing. Please copy and paste invoice data manually."
Exit Sub
End If
Page2 = Split(Page2, "Job Type", , vbTextCompare)
'Extract Invoice No.
InvoiceNo = Split(Page2(0), "Invoice No:", , vbTextCompare)(1)
InvoiceNo = VBA.Replace(InvoiceNo, Chr(10), "")
InvoiceNo = VBA.Replace(InvoiceNo, Chr(13), "")
InvoiceNo = Trim(InvoiceNo)
'Extract Invoice Table
InvoiceTable = Split(Page2(1), Chr(13), , vbTextCompare)
'On Error GoTo Error_InvoiceNo
'Check destination for pasting
For Each Cell In Range(ActiveCell, ActiveCell.Offset(UBound(InvoiceTable) - 1, 5))
If IsEmpty(Cell) = False Or Cell.MergeCells = True Then
MsgBox "Please make sure you selected the right cell for pasting invoice data, the destination range is empty and doesn't contain merged cells."
Exit Sub
End If
Next Cell
'Paste Data
On Error GoTo Error_PasteData
For i = 1 To UBound(InvoiceTable)
'get next row
Row = VBA.Replace(InvoiceTable(i), Chr(10), "")
Row = VBA.Replace(Row, "-", "0")
Row = Split(Row, " ", , vbTextCompare)
'stop data pasting if end of data core is reached
If InStr(Row(0), "SUM") > 0 Then Exit For
'paste data row
ActiveCell.Value = InvoiceNo
If InStr(Row(0), "Fixed") > 0 Then
ActiveCell.Offset(0, 1).Value = Join(Array(Row(0), Row(1)))
ActiveCell.Offset(0, 5).Value = CDbl(Row(3))
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(0, 1).Value = Row(0)
ActiveCell.Offset(0, 2).Value = Join(Array(Row(1), Row(2)))
ActiveCell.Offset(0, 3).Value = CDbl(Row(3))
ActiveCell.Offset(0, 4).Value = CDbl(Row(5))
ActiveCell.Offset(0, 5).Value = CDbl(Row(7))
ActiveCell.Offset(1, 0).Select
End If
Next i
On Error GoTo 0
'Error message in case of data pasting error
If blnError_PasteData Then
MsgBox "An Error occured. Please fill in missing data manually."
End If
Exit Sub
'Error handling
Error_PasteData:
blnError_PasteData = True
Resume Next
End Sub
Module 3:
Sub Compare_Consumption_Invoice_Overview()
Dim CompareRange As Variant, x As Variant, y As Variant, rowOffset As Variant, colOffset As Variant
' Set CompareRange equal to the range to which you will
' compare the selection. (Invoices Table)
If Selection.Rows(1).Row < 26 Then
Set CompareRange = Range("C44:N81")
rowOffset = -1 'First row starts at 2
colOffset = -2 'First column is C
Else
Set CompareRange = Range("C2:N39")
rowOffset = -29 ' First row starts from 30
colOffset = -2 'First column is C
End If
' NOTE: If the compare range is located on another workbook
' or worksheet, use the following syntax.
' Set CompareRange = Workbooks("Book2"). _
' Worksheets("Sheet2").Range("C1:C5")
'
' Loop through each cell in the selection and compare it to
' corresponding cell in CompareRange.
Dim correspondingCell As Range
For Each x In Selection
Set correspondingCell = CompareRange.Cells(x.Row + rowOffset, x.Column + colOffset)
'MsgBox x.Value & " ... " & correspondingCell.Value
If Int(x) = Int(correspondingCell.Value) Then ' Int(12.04) returns 12. Better for comparison
x.Interior.ColorIndex = 4
correspondingCell.Interior.ColorIndex = 4
Else
x.Interior.ColorIndex = 6
correspondingCell.Interior.ColorIndex = 6
End If
Next x
End Sub
Vielen Dank im Voraus
Beste Grüße,
ButterFly
|