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