Imports System.Globalization Imports Microsoft.Office.Interop Public Class frmBH_SollHaben Public Sub New() ' Dieser Aufruf ist für den Designer erforderlich. InitializeComponent() ' Fügen Sie Initialisierungen nach dem InitializeComponent()-Aufruf hinzu. End Sub 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 ' MsgBox("start0") 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 ' MsgBox("startRows" & startRows) Dim endRows As Integer = Blatt.UsedRange.Rows.Count While endRows > 0 If Not Blatt.Range("B" & endRows) Is Nothing Then If Blatt.Range("B" & endRows).Value = "Summe:" Then endRows -= 1 endFound = True Exit While End If End If endRows -= 1 End While Dim tabu As New List(Of Integer) '__________________ '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 'AUSZIFFERN SOLL Dim ausziffern_soll As Integer = 1 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 If checkNothingEmptyBool(myArray(i_soll - startRows + 1, 3)) AndAlso checkNothingEmptyBool(myArray(i_soll2 - startRows + 1, 3)) Then Dim sollNr As String = getnumberFromSollHaben(myArray(i_soll - startRows + 1, 3)) 'posNr aus zelle suchen Dim habenNr As String = getnumberFromSollHaben(myArray(i_soll2 - startRows + 1, 3)) 'posNr aus zelle suchen 'MsgBox("sollNr" & myArray(i_soll - startRows + 1, 3).ToString & " - " & sollNr) 'MsgBox("habenNr" & myArray(i_haben - startRows + 1, 3).ToString & " - " & habenNr) If (sollNr.Trim <> "" AndAlso habenNr.Trim <> "" AndAlso sollNr = habenNr) Or (myArray(i_soll - startRows + 1, 3).ToString = myArray(i_soll2 - startRows + 1, 3).ToString) Then 'posNr vergleichen, oder fall der ganze Text exakt übereinstimmt ' MsgBox(CDbl(soll) & " _ " & CDbl(soll2)) Blatt.Range("K" & i_soll).Value = ausziffern_soll Blatt.Range("K" & i_soll2).Value = ausziffern_soll 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_soll += 1 tabu.Add(i_soll) tabu.Add(i_soll2) Exit For End If 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(ex.Message) Return False End Try lblSoll.Text = "SOLL Auszifferung OK" 'AUSZIFFERN Haben Dim ausziffern_haben As Integer = 1 ' Dim tabu_haben As New List(Of Integer) lblHaben.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, 6) Dim soll2 As Object = myArray(i_soll2 - startRows + 1, 6) 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 If checkNothingEmptyBool(myArray(i_soll - startRows + 1, 3)) AndAlso checkNothingEmptyBool(myArray(i_soll2 - startRows + 1, 3)) Then Dim sollNr As String = getnumberFromSollHaben(myArray(i_soll - startRows + 1, 3)) 'posNr aus zelle suchen Dim habenNr As String = getnumberFromSollHaben(myArray(i_soll2 - startRows + 1, 3)) 'posNr aus zelle suchen 'MsgBox("sollNr" & myArray(i_soll - startRows + 1, 3).ToString & " - " & sollNr) 'MsgBox("habenNr" & myArray(i_haben - startRows + 1, 3).ToString & " - " & habenNr) If (sollNr.Trim <> "" AndAlso habenNr.Trim <> "" AndAlso sollNr = habenNr) Or (myArray(i_soll - startRows + 1, 3).ToString = myArray(i_soll2 - startRows + 1, 3).ToString) Then 'posNr vergleichen, oder fall der ganze Text exakt übereinstimmt ' MsgBox(CDbl(soll) & " _ " & CDbl(soll2)) Blatt.Range("K" & i_soll).Value = ausziffern_haben Blatt.Range("K" & i_soll2).Value = ausziffern_haben 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_haben += 1 tabu.Add(i_soll) tabu.Add(i_soll2) Exit For End If End If End If End If End If End If End If Next lblHaben.Text = "HABEN Auszifferung... " & CInt(i_soll / (endRows / 100)) & "%" Next Catch ex As Exception lblFehler.Visible = True Button1.Visible = True Me.Cursor = Cursors.Default MsgBox(ex.Message) Return False End Try lblHaben.Text = "HABEN Auszifferung OK" 'SOLL/HABEN ausziffern Dim ausziffern As Integer = 1 'Dim tabu As New List(Of Integer) Dim POS_NR = False 'posNr vergleichen Try lblSollHaben.Visible = True For i_soll As Integer = startRows To endRows Step 1 For i_haben As Integer = startRows To endRows Step 1 Dim soll As Object = myArray(i_soll - startRows + 1, 5) Dim haben As Object = myArray(i_haben - startRows + 1, 6) If Not soll Is Nothing AndAlso Not haben Is Nothing Then 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 'TextBox1.Text = myArray(i_soll - startRows + 1, 3) & " - " & myArray(i_soll2 - startRows + 1, 3) ' MsgBox(soll.ToString & " _ " & haben.ToString) If soll.ToString = haben.ToString Then If checkNothingEmptyBool(myArray(i_soll - startRows + 1, 3)) AndAlso checkNothingEmptyBool(myArray(i_haben - startRows + 1, 3)) Then Dim sollNr As String = getnumberFromSollHaben(myArray(i_soll - startRows + 1, 3)) 'posNr aus zelle suchen Dim habenNr As String = getnumberFromSollHaben(myArray(i_haben - startRows + 1, 3)) 'posNr aus zelle suchen 'MsgBox("sollNr" & myArray(i_soll - startRows + 1, 3).ToString & " - " & sollNr) 'MsgBox("habenNr" & myArray(i_haben - startRows + 1, 3).ToString & " - " & habenNr) If Not POS_NR OrElse (sollNr.Trim <> "" AndAlso habenNr.Trim <> "" AndAlso sollNr = habenNr) Then 'posNr vergleichen ' MsgBox("OK3") 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_soll) tabu.Add(i_haben) Exit For End If End If End If End If End If End If End If Next lblSollHaben.Text = "SOLL/HABEN Auszifferung... " & CInt(i_soll / (endRows / 100)) & "%" Next lblSollHaben.Text = "SOLL/HABEN Auszifferung OK" Catch ex As Exception lblFehler.Visible = True Button1.Visible = True Me.Cursor = Cursors.Default MsgBox(ex.Message) Return False End Try 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 Me.Cursor = Cursors.Default .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) 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 checkNothingEmptyBool(s) As Boolean If s Is Nothing Then Return False If s = "" Then Return False Return True End Function Function getnumberFromSollHaben(s As Object) As String If Not s Is Nothing AndAlso s.ToString <> "" Then If matchFormat(s.ToString) Then getnumberFromSollHaben = getNumberFromBehindMatching(s.ToString) Else getnumberFromSollHaben = getNumberFromBehind(s.ToString) End If Else getnumberFromSollHaben = "" End If End Function Function matchFormat(s As String) As Boolean If Not s.Length = 16 Then Return False If Not s(4) = "/" Then Return False If Not s(13) = "/" Then Return False If Not IsNumeric(s.ToString.Substring(0, 4)) Then Return False If Not IsNumeric(s.ToString.Substring(5, 8)) Then Return False If Not IsNumeric(s.ToString.Substring(14, 2)) Then Return False Return True End Function Function getNumberFromBehind(s As String) As String Dim startint As Boolean = False Dim int As String = "" For i As Integer = s.Length - 1 To 0 Step -1 If startint And Not IsNumeric(s(i)) Then If int.Length < 3 Then ' Wenn die Zahl kleiner als 3 ist, kann Sie nicht stimmen, --> weitersuchen startint = False 'Param zurücksetzen int = "" 'Param zurücksetzen Else Exit For 'Zahl stimmt, suche wird beendet End If End If If IsNumeric(s(i)) Then int = s(i) & int startint = True End If Next While int.Length > 1 AndAlso int.StartsWith("0") int = int.Substring(1, int.Length - 1) End While Return int End Function Function getNumberFromBehindMatching(s As String) As String Dim int As String = s.ToString.Substring(8, 5) While int.Length > 1 AndAlso int.StartsWith("0") int = int.Substring(1, int.Length - 1) End While Return int 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