I was assigned the task of copying some subsums from a given EXCEL-Sheet into the executing EXCEL-Sheet.
This had to be done with an EXCEL-Macro, so non-programmers can easily use it. There was the need to compare the final sum of copied values to the sum of values in the given sheet, as it's about business critical finance.
What can be said about the readability and maintainability?
Enough talk, here's the code. I am inserting <hr>
to divide the code into it's logical parts. That should make it more readable.
Sub TelekomRechnungEinlesen()
Dim lastSetTelekomRow As Long
Dim lastSetNovatecRow As Long
Dim iterator As Long
Dim novatecSumColumn As String
Dim mobilenumberSpalte As String
Dim subSumFlag As String
Dim bereichsSpalte As String
Dim bereichsWert As String
Dim telekomSumColumn As String
Dim mobilenumber As String
Dim NTmobilenumber As String
' used worksheet shortcuts
Dim TKSheet As Worksheet
Dim NTSheet As Worksheet
' final comparison required stuff
Dim novatecSum As Double
Dim telekomSum As Double
Dim closeflag As Boolean
mobilenumberSpalte = "D"
bereichsSpalte = "F"
novatecSumColumn = "E"
telekomSumColumn = "O"
bereichsWert = "Telekom Deutschland GmbH"
' Select Target worksheet
Workbooks(1).Worksheets(1).Activate
Set NTSheet = ActiveSheet
lastSetNovatecRow = LastRowInGivenSheet(NTSheet)
NTSheet.Range(novatecSumColumn & "2:" & novatecSumColumn & lastSetNovatecRow).Value = ""
' Open file dialog
FileToOpen = Application.GetOpenFilename _
(Title:="Bitte Telekomrechnung auswählen", _
FileFilter:="Excel Files *.xls (*.xls),")
If FileToOpen = False Then
MsgBox "Keine Datei ausgewählt", vbExclamation, "Fehler!"
Exit Sub
Else
Workbooks.Open Filename:=FileToOpen
End If
Workbooks(2).Worksheets(3).Activate
Set TKSheet = ActiveSheet
lastSetTelekomRow = LastRowInGivenSheet(TKSheet)
tCol = novatecSumColumn
' Start Data Transfer
For tkI = 2 To lastSetTelekomRow
iterator = 2
subSumFlag = TKSheet.Range(bereichsSpalte & tkI).Value
mobilenumber = TKSheet.Range(mobilenumberSpalte & tkI).Value
While (iterator <= lastSetNovatecRow)
NTmobilenumber = NTSheet.Range("C" & iterator).Value
If mobilenumber = NTmobilenumber And subSumFlag = bereichsWert Then
' Copy the subtotal
NTSheet.Range(tCol & iterator).Value = NTSheet.Range(tCol & iterator).Value + TKSheet.Range(telekomSumColumn & tkI).Value
' Copy some additional stuff
NTSheet.Range("A" & iterator) = TKSheet.Range("C" & tkI).Value
NTSheet.Range("B" & iterator) = TKSheet.Range("B" & tkI).Value
' mark as taken into account
TKSheet.Range("A" & tkI & ":" & telekomSumColumn & tkI).Interior.Color = RGB(200, 200, 80)
End If
iterator = iterator + 1
Wend
Next tkI
telekomSum = WorksheetFunction.SumIf(TKSheet.Range(bereichsSpalte & "2:" & bereichsSpalte & lastSetTelekomRow), _
bereichsWert, TKSheet.Range(telekomSumColumn & "2:" & telekomSumColumn & lastSetTelekomRow))
novatecSum = WorksheetFunction.sum(NTSheet.Range(tCol & "2:" & tCol & lastSetNovatecRow))
closeflag = True
If Abs(telekomSum - novatecSum) >= 0.01 Then
' Error Message
MsgBox "Summen stimmen nicht überein. " & _
"Bitte überprüfen Sie die eingepflegten Verträge und Mobilfunknummern:" & vbCrLf & "NovaTec: " & _
novatecSum & "€" & vbCrLf & "Telekom: " & gesamt & "€" & vbCrLf & vbCrLf & _
"Doppelte Mobilfunknummern wurden in Ihrem Excel-Sheet markiert." & vbCrLf & _
"Diese sind Hauptfehlerursache. Bitte beseitigen Sie eventuell doppelte Einträge" & _
vbCrLf & vbCrLf & "Außerdem wurden in der Angegebenen Rechnung alle einbezogenen Subtotalen markiert" _
, vbExclamation, "INFO:"
' Prevent closing of imported file
closeflag = False
' Troubleshooting help for user
NTSheet.Range("C2:C" & lastSetNovatecRow).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlDuplicate
Selection.FormatConditions(1).Interior.Color = RGB(255, 40, 80)
End If
If closeflag Then
' Close without saving
Workbooks(2).Close (False)
End If
' Show compared values in the opened worksheet
NTSheet.Range(tCol & lastSetNovatecRow + 2).Value = novatecSum
NTSheet.Range("D" & lastSetNovatecRow + 2).Value = "NovaTec Summe"
NTSheet.Range(tCol & lastSetNovatecRow + 3).Value = telekomSum
NTSheet.Range("D" & lastSetNovatecRow + 3).Value = "Telekom Summe"
NTSheet.Range(tCol & lastSetNovatecRow + 4).Formula = "= " & tCol & lastSetNovatecRow + 2 & "-" & tCol & lastSetNovatecRow + 3
NTSheet.Range("D" & lastSetNovatecRow + 4).Value = "Differenz:"
End Sub
Function LastRowInGivenSheet(ByVal sheet As Worksheet) As Long
Dim found As Boolean
Dim LastRow As Long
LastRow = 1
found = False
While Not found
If sheet.Range("A" & (LastRow + 1)).Value = "" Then
found = True
Else
LastRow = LastRow + 1
End If
Wend
LastRowInGivenSheet = LastRow
End Function
I apologize for the variable naming... I decided to make the "configurable" variables German, as they should be maintainable by non-english speakers, in case the conditions and columns change ...