391 lines
20 KiB
VB.net
391 lines
20 KiB
VB.net
Imports System.Globalization
|
|
Imports Microsoft.Office.Interop
|
|
|
|
|
|
Public Class frmMDM_BH_SollHaben
|
|
Public MdmSollHaben As Boolean = False
|
|
Public MdmSollHabenOhneKdNr As Boolean = False
|
|
Public MdmSollSoll As Boolean = False
|
|
Public MdmHabenHaben As Boolean = False
|
|
|
|
Private Function loadExcel() As Boolean
|
|
' Call ShowDialog.
|
|
|
|
Dim fd As New OpenFileDialog
|
|
fd.Filter = "Excel Dateien|*.xls;*.xlsx"
|
|
Dim result As DialogResult = fd.ShowDialog()
|
|
|
|
If Not fd.FileName.EndsWith(".xls") And Not fd.FileName.EndsWith(".xlsx") Then Exit Function
|
|
|
|
|
|
If result = System.Windows.Forms.DialogResult.OK Then
|
|
lblOpen.Visible = True
|
|
'Label1.Visible = True
|
|
' Button1.Enabled = False
|
|
Me.Cursor = Cursors.WaitCursor
|
|
Dim exclApp As New Excel.Application 'Object 'as Application
|
|
Dim Datei As Excel.Workbook ' 'as WorkBook
|
|
Dim Blatt As Excel.Worksheet 'Object 'as WorkSheet
|
|
' exclApp = CreateObject("Excel.Application")
|
|
|
|
With exclApp
|
|
Try
|
|
|
|
' .Visible = False
|
|
' Dim GuiId As String = System.Guid.NewGuid().ToString().ToUpper()
|
|
' exclApp.Caption = GuiId
|
|
exclApp.CutCopyMode = False
|
|
|
|
Datei = .Workbooks.Open(fd.FileName)
|
|
Blatt = Datei.Worksheets(1)
|
|
|
|
Datei.Activate()
|
|
|
|
|
|
Try
|
|
Blatt.ShowAllData() 'Falls Filter ausgewählt wurde
|
|
Catch ex As Exception
|
|
|
|
End Try
|
|
|
|
Dim startFound As Boolean = False
|
|
Dim endFound As Boolean = False
|
|
|
|
|
|
Dim startRows As Integer = 1
|
|
|
|
While startRows < Blatt.UsedRange.Rows.Count
|
|
If Blatt.Range("A" & startRows).Value IsNot Nothing AndAlso Blatt.Range("A" & startRows).Value.ToString = "Belegdat." Then
|
|
startRows += 2
|
|
startFound = True
|
|
Exit While
|
|
End If
|
|
startRows += 1
|
|
End While
|
|
|
|
Dim endRows As Integer = Blatt.UsedRange.Rows.Count
|
|
While endRows > 0
|
|
If Blatt.Range("A" & endRows) IsNot Nothing Then
|
|
If IsDate(Blatt.Range("A" & endRows).Value) Then
|
|
endFound = True
|
|
Exit While
|
|
End If
|
|
End If
|
|
endRows -= 1
|
|
End While
|
|
|
|
'__________________
|
|
|
|
'Laden des Bereiches aus dem Excel:
|
|
Dim myRange As Excel.Range
|
|
myRange = Blatt.Range("A" & startRows & ":H" & endRows & "")
|
|
Dim myArray As Object(,) '<-- declared as 2D Array
|
|
myArray = myRange.Value 'store the content of each cell
|
|
|
|
|
|
Dim ausziffern_einzeln As Integer = 1
|
|
|
|
Dim tabu As New List(Of Integer)
|
|
'AUSZIFFERN SOLL
|
|
If MdmSollSoll Then
|
|
|
|
|
|
lblSoll.Visible = True
|
|
Try
|
|
For i_soll As Integer = startRows To endRows Step 1
|
|
For i_soll2 As Integer = startRows To endRows Step 1
|
|
|
|
Dim soll As Object = myArray(i_soll - startRows + 1, 5)
|
|
Dim soll2 As Object = myArray(i_soll2 - startRows + 1, 5)
|
|
If Not soll Is Nothing AndAlso Not soll2 Is Nothing Then
|
|
|
|
If isNotTabu2(tabu, i_soll, i_soll2) Then ' wurde diese zeile schon ausgeziffert?
|
|
If Not soll Is Nothing AndAlso Not soll2 Is Nothing Then
|
|
If soll.ToString.Trim <> "" AndAlso soll2.ToString.Trim <> "" Then
|
|
|
|
If CDbl(soll) + CDbl(soll2) = CDbl(0) Then
|
|
Dim sollkdNr As String = myArray(i_soll - startRows + 1, 8).ToString 'posNr aus zelle suchen
|
|
Dim sollkdNr2 As String = myArray(i_soll2 - startRows + 1, 8).ToString 'posNr aus zelle suchen
|
|
|
|
If (sollkdNr.Trim <> "" AndAlso sollkdNr2.Trim <> "" AndAlso sollkdNr.Trim = sollkdNr2.Trim) Then 'posNr vergleichen, oder fall der ganze Text exakt übereinstimmt
|
|
|
|
' MsgBox(CDbl(soll) & " _ " & CDbl(soll2))
|
|
Blatt.Range("K" & i_soll).Value = ausziffern_einzeln
|
|
Blatt.Range("K" & i_soll2).Value = ausziffern_einzeln
|
|
Blatt.Range("A" & i_soll & ":K" & i_soll).Font.Color = Color.RoyalBlue
|
|
Blatt.Range("A" & i_soll2 & ":K" & i_soll2).Font.Color = Color.RoyalBlue
|
|
ausziffern_einzeln += 1
|
|
tabu.Add(i_soll)
|
|
tabu.Add(i_soll2)
|
|
Exit For
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
Next
|
|
lblSoll.Text = "SOLL Auszifferung... " & CInt(i_soll / (endRows / 100)) & "%"
|
|
Next
|
|
Catch ex As Exception
|
|
lblFehler.Visible = True
|
|
Button1.Visible = True
|
|
Me.Cursor = Cursors.Default
|
|
MsgBox("ER01: " & ex.Message & ex.StackTrace)
|
|
|
|
Return False
|
|
End Try
|
|
lblSoll.Text = "SOLL Auszifferung OK"
|
|
|
|
End If
|
|
|
|
'AUSZIFFERN HABEN
|
|
If MdmHabenHaben Then
|
|
Dim i_haben As Integer = 0
|
|
Dim i_haben2 As Integer = 0
|
|
' Dim ausziffern_haben As Integer = 1
|
|
' Dim tabu_haben As New List(Of Integer)
|
|
lblHaben.Visible = True
|
|
Try
|
|
For i_haben = startRows To endRows Step 1
|
|
For i_haben2 = startRows To endRows Step 1
|
|
Dim haben As Object = myArray(i_haben - startRows + 1, 6)
|
|
Dim haben2 As Object = myArray(i_haben2 - startRows + 1, 6)
|
|
If Not haben Is Nothing AndAlso Not haben2 Is Nothing Then
|
|
|
|
If isNotTabu2(tabu, i_haben, i_haben2) Then ' wurde diese zeile schon ausgeziffert?
|
|
If Not haben Is Nothing AndAlso Not haben2 Is Nothing Then
|
|
If haben.ToString.Trim <> "" AndAlso haben2.ToString.Trim <> "" Then
|
|
|
|
If CDbl(haben) + CDbl(haben2) = CDbl(0) Then
|
|
Dim habenkdNr As String = getKdNrFromHaben(myArray(i_haben - startRows + 1, 3)) 'posNr aus zelle suchen
|
|
Dim habenkdNr2 As String = getKdNrFromHaben(myArray(i_haben2 - startRows + 1, 3)) 'posNr aus zelle suchen
|
|
|
|
If Not habenkdNr Is Nothing AndAlso Not habenkdNr2 Is Nothing Then
|
|
If (habenkdNr.Trim <> "" AndAlso habenkdNr2.Trim <> "" AndAlso habenkdNr.Trim = habenkdNr2.Trim) Then 'posNr vergleichen, oder fall der ganze Text exakt übereinstimmt
|
|
|
|
' MsgBox(CDbl(haben) & " _ " & CDbl(haben2))
|
|
Blatt.Range("K" & i_haben).Value = ausziffern_einzeln
|
|
Blatt.Range("K" & i_haben2).Value = ausziffern_einzeln
|
|
Blatt.Range("A" & i_haben & ":K" & i_haben).Font.Color = Color.RoyalBlue
|
|
Blatt.Range("A" & i_haben2 & ":K" & i_haben2).Font.Color = Color.RoyalBlue
|
|
ausziffern_einzeln += 1
|
|
tabu.Add(i_haben)
|
|
tabu.Add(i_haben2)
|
|
Exit For
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
Next
|
|
lblHaben.Text = "HABEN Auszifferung... " & CInt(i_haben / (endRows / 100)) & "%"
|
|
Next
|
|
Catch ex As Exception
|
|
lblFehler.Visible = True
|
|
Button1.Visible = True
|
|
Me.Cursor = Cursors.Default
|
|
MsgBox("ER02: " & ex.Message & vbNewLine & " i_haben: " & i_haben & vbNewLine & " i_haben2: " & i_haben2 & vbNewLine & ex.StackTrace)
|
|
Return False
|
|
End Try
|
|
lblHaben.Text = "HABEN Auszifferung OK"
|
|
|
|
End If
|
|
|
|
|
|
|
|
'NEU ANFANG
|
|
'SOLL/HABEN ausziffern
|
|
If MdmSollHaben Then
|
|
Dim ausziffern As Integer = 1
|
|
' Dim tabu As New List(Of Integer)
|
|
Dim i_s_tmp As Integer = 0
|
|
Dim i_h_tmp As Integer = 0
|
|
Try
|
|
|
|
lblSollHaben.Visible = True
|
|
For i_cnt As Integer = startRows To endRows Step 1
|
|
|
|
Dim soll As Object = myArray(i_cnt - startRows + 1, 5)
|
|
Dim haben As Object = myArray(i_cnt - startRows + 1, 6)
|
|
|
|
For i_cnt2 As Integer = startRows To endRows Step 1
|
|
i_s_tmp = i_cnt
|
|
i_h_tmp = i_cnt2
|
|
haben = myArray(i_cnt2 - startRows + 1, 6)
|
|
If Not haben Is Nothing Then
|
|
Dim i_soll = i_cnt
|
|
Dim i_haben = i_cnt2
|
|
|
|
If isNotTabu2(tabu, i_soll, i_haben) Then ' wurde diese zeile schon ausgeziffert?
|
|
If Not soll Is Nothing AndAlso Not haben Is Nothing Then
|
|
If soll.ToString.Trim <> "" AndAlso haben.ToString.Trim <> "" Then
|
|
If soll.ToString = haben.ToString Then
|
|
Dim sollKdNr As String = (myArray(i_soll - startRows + 1, 8)) 'posNr aus zelle suchen
|
|
Dim habenkdNr As String = getKdNrFromHaben(myArray(i_haben - startRows + 1, 3)) 'posNr aus zelle suchen
|
|
' Dim habenkdNr2 As String = (myArray(i_haben - startRows + 1, 7)) 'posNr aus zelle suchen
|
|
|
|
If (sollKdNr.Trim <> "" AndAlso habenkdNr.Trim <> "" AndAlso sollKdNr.Trim = habenkdNr.Trim) Then 'Or (sollKdNr.Trim = habenkdNr2.Trim) Then 'posNr vergleichen, oder fall der ganze Text exakt übereinstimmt; OR: WEnn bei beiden das geliche Gegenkonto angeführt ist
|
|
|
|
Blatt.Range("J" & i_soll).Value = ausziffern
|
|
Blatt.Range("J" & i_haben).Value = ausziffern
|
|
Blatt.Range("A" & i_soll & ":J" & i_soll).Font.Color = Color.Red
|
|
Blatt.Range("A" & i_haben & ":J" & i_haben).Font.Color = Color.Red
|
|
ausziffern += 1
|
|
tabu.Add(i_haben)
|
|
tabu.Add(i_soll)
|
|
Exit For
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
Next
|
|
|
|
lblSollHaben.Text = "SOLL/HABEN Auszifferung... " & CInt(i_cnt / (endRows / 100) / 2) & "%"
|
|
Next
|
|
|
|
'OHNE ÜBERPRÜFUNG
|
|
If MdmSollHabenOhneKdNr Then
|
|
For i_cnt As Integer = startRows To endRows Step 1
|
|
Dim soll As Object = myArray(i_cnt - startRows + 1, 5)
|
|
Dim haben As Object = myArray(i_cnt - startRows + 1, 6)
|
|
For i_cnt2 As Integer = startRows To endRows Step 1
|
|
i_s_tmp = i_cnt
|
|
i_h_tmp = i_cnt2
|
|
haben = myArray(i_cnt2 - startRows + 1, 6)
|
|
If Not haben Is Nothing Then
|
|
Dim i_soll = i_cnt
|
|
Dim i_haben = i_cnt2
|
|
|
|
If isNotTabu2(tabu, i_soll, i_haben) Then ' wurde diese zeile schon ausgeziffert?
|
|
If Not soll Is Nothing AndAlso Not haben Is Nothing Then
|
|
If soll.ToString.Trim <> "" AndAlso haben.ToString.Trim <> "" Then
|
|
|
|
If soll.ToString = haben.ToString Then
|
|
Blatt.Range("J" & i_soll).Value = ausziffern
|
|
Blatt.Range("J" & i_haben).Value = ausziffern
|
|
Blatt.Range("A" & i_soll & ":J" & i_soll).Font.Color = Color.DarkGreen
|
|
Blatt.Range("A" & i_haben & ":J" & i_haben).Font.Color = Color.DarkGreen
|
|
ausziffern += 1
|
|
tabu.Add(i_haben)
|
|
tabu.Add(i_soll)
|
|
Exit For
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
End If
|
|
Next
|
|
|
|
lblSollHaben.Text = "SOLL/HABEN Auszifferung... " & CInt(i_cnt / (endRows / 100) / 2) + 50 & "%"
|
|
Next
|
|
End If
|
|
'OHNE ÜBERPRÜFUNG ENDE
|
|
|
|
|
|
lblSollHaben.Text = "SOLL/HABEN Auszifferung OK"
|
|
|
|
Catch ex As Exception
|
|
|
|
lblFehler.Visible = True
|
|
Button1.Visible = True
|
|
Me.Cursor = Cursors.Default
|
|
MsgBox("ER03: " & ex.Message & vbNewLine & "Zähler1: " & i_s_tmp & vbNewLine & "Zähler2: " & i_h_tmp & vbNewLine & ex.StackTrace)
|
|
Return False
|
|
End Try
|
|
|
|
End If
|
|
'NEU ENDE
|
|
|
|
Blatt.Range("J" & (startRows - 2)).Value = "SOLL/HABEN Ausziff."
|
|
Blatt.Range("K" & (startRows - 2)).Value = "Einseitige Ausziff."
|
|
|
|
Blatt.Range("A1:K1").EntireColumn.AutoFit()
|
|
|
|
lblExcel.Visible = True
|
|
|
|
.Visible = True
|
|
AddHandler exclApp.WorkbookBeforeClose, AddressOf BeforeBookClose
|
|
'Excelobjekte freistellten
|
|
For Each obj In New Object() {exclApp, Datei, Datei, Blatt, Blatt}
|
|
System.Runtime.InteropServices.Marshal.FinalReleaseComObject(obj)
|
|
Next
|
|
|
|
Catch ex As Exception
|
|
lblFehler.Visible = True
|
|
Button1.Visible = True
|
|
Me.Cursor = Cursors.Default
|
|
MsgBox("FEHLER! Wurde die richtige Datei ausgewählt?" & vbNewLine & vbNewLine & ex.Message & ex.StackTrace)
|
|
Return False
|
|
End Try
|
|
End With
|
|
Return True
|
|
Else
|
|
Me.Close()
|
|
Return False
|
|
End If
|
|
Me.Enabled = True
|
|
Me.Cursor = Cursors.Default
|
|
|
|
Return False
|
|
|
|
End Function
|
|
|
|
|
|
Function getKdNrFromHaben(s As Object) As String
|
|
Dim kdnr As String = ""
|
|
If Not s Is Nothing AndAlso s <> "" Then
|
|
If IsNumeric(s) Then Return s
|
|
If s.Length > 0 Then
|
|
For index = 0 To s.Length - 1
|
|
If IsNumeric(s.Substring(index, 1)) Then
|
|
Dim i As Integer = 1
|
|
While IsNumeric(s.Substring(index, i)) And s.Length > index + i
|
|
kdnr = s.Substring(index, i)
|
|
i += 1
|
|
End While
|
|
Return kdnr
|
|
End If
|
|
Next
|
|
End If
|
|
End If
|
|
Return kdnr
|
|
End Function
|
|
Private Sub BeforeBookClose(ByVal Wb As Excel.Workbook, ByRef Cancel As Boolean)
|
|
' Wb.Application.Quit()
|
|
'Wb.Close()
|
|
|
|
Me.Close()
|
|
End Sub
|
|
Private Sub frmMDM_BH_SollHaben_Load(sender As Object, e As EventArgs) Handles Me.Load
|
|
lblSoll.Text = "Laden... 0%"
|
|
Me.Show()
|
|
Me.BringToFront()
|
|
loadExcel()
|
|
End Sub
|
|
Function isNotTabu(tabu As List(Of Integer), i_haben As Integer) As Boolean
|
|
If Not tabu Is Nothing Then
|
|
For Each t In tabu
|
|
If t = i_haben Then Return False
|
|
Next
|
|
End If
|
|
Return True
|
|
End Function
|
|
Function isNotTabu2(tabu As List(Of Integer), w1 As Integer, w2 As Integer) As Boolean
|
|
If Not tabu Is Nothing Then
|
|
For Each t In tabu
|
|
If t = w2 Then Return False
|
|
If t = w1 Then Return False
|
|
Next
|
|
End If
|
|
Return True
|
|
End Function
|
|
|
|
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
|
|
Me.Close()
|
|
End Sub
|
|
End Class |