Jak wyszukać igłę w stogu siana? A jak znaleźć kilkanaście tysięcy błędnych faktur w „sianie” złożonym z półtora miliona wierszy arkusza kalkulacyjnego? Sprawdziłem, że jedna osoba może odszukać jeden taki błąd w czasie mniej więcej 15 minut. Wystarczy pomnożyć przez te tysiące i otrzymamy…– trzeba siedzieć bez przerwy PÓŁ ROKU, 24 godziny na dobę, przez 7 dni w tygodniu.

Te prawie 200 linijek stworzone i przetestowane w kilka godzin umożliwiają wczytanie niezbędnych danych, automatyczne porównanie i wypisanie na kilka różnych sposobów znalezionych braków. Pół roku pracy zamienia się na kilkadziesiąt minut pracy typowego komputera.

mgr inż. Wacław Libront

Sub Porównaj()
  Sheets("są").Select
  Cells.Select
  Selection.ClearContents
  Sheets("brak").Select
  Cells.Select
  Selection.ClearContents
  
  w = 1
  w1 = 1
  w2 = 1
  jak = Sheets("centrum").Range("A1")
  Do
    kwota = Sheets("centrum").Cells(w, 7)
    numer = Sheets("centrum").Cells(w, 3)
    kto = Sheets("centrum").Cells(w, 1)
    dat = Sheets("centrum").Cells(w, 2)
    
    If kwota < 0 Then
      x = SprawdzajFakturę(numer)
      'jest numer w f1
      If x > 0 Then
        Sheets("są").Cells(w1, 1) = w
        Sheets("są").Cells(w1, 2) = numer
        Sheets("są").Cells(w1, 3) = x
        Sheets("są").Cells(w1, 4) = kto
        Sheets("są").Cells(w1, 5) = dat
        Sheets("są").Cells(w1, 6) = kwota
        'jeśli kwoty się r óżnią w znalezionych
        kwota1 = Sheets("euro").Cells(x, 15)
        If kwota <> kwota1 Then
          Sheets("są").Cells(w1, 7) = kwota1
          Sheets("są").Rows(w1).Interior.ColorIndex = 22
        End If
        'dopisać jedynkę jeśli znaleiono w centrum
        Sheets("centrum").Cells(w, 9) = 1
        'pokolorować znalezione w euro
        Sheets("euro").Cells(x, 20) = 1
        Sheets("euro").Rows(x).Interior.ColorIndex = 22
        w1 = w1 + 1
      End If
      'nie ma takiego numeru w f2
      If x = 0 Then
        Sheets("brak").Cells(w2, 1) = w
        Sheets("brak").Cells(w2, 2) = numer
        Sheets("brak").Cells(w2, 4) = kto
        Sheets("brak").Cells(w2, 5) = dat
        Sheets("brak").Cells(w2, 6) = kwota
        
        Sheets("brak").Cells(w2, 1).Select
        Sheets("centrum").Rows(w).Interior.ColorIndex = 22
        
        Sheets("centrum").Cells(w, 9) = -1
        w2 = w2 + 1
      End If
    End If 'ujemna kwota
    
    w = w + 1
  Loop Until Sheets("centrum").Cells(w, 1) = ""
  Sheets("brak").Select
  Range("a1").Select
End Sub


Function SprawdzajFakturę(numer As Variant) As Integer
On Error GoTo błąd
  SprawdzajFakturę = Sheets("euro").Columns("D:D").Find(What:=numer).Row
Exit Function
błąd:
  SprawdzajFakturę = 0
End Function

'pobieramy plik z EUROCASH
Sub PobierzPlikEUROCASH()
  'aktywny arkusz
  Adokąd = ActiveWorkbook.Name
  Zdokąd = "euro"
'wyczyszczenie poprzednich
  Sheets(Zdokąd).Select
  Cells.Select
  Selection.ClearContents
  'kolory
  Cells.Select
    With Selection.Interior
        .Pattern = xlNone
    End With
  Range("A1").Select
  
  wynik = Application.Dialogs(xlDialogOpen).Show
  If wynik = False Then
    MsgBox "BŁĄD"
    Exit Sub
  End If
  'plik otwarty
  'nazwa otwartego arkusza
  Askąd = ActiveWorkbook.Name
  'nazwa wybranej zakłądki w arkuszu
  Zskąd = ActiveSheet.Name
  'Zskąd = "Przydziały - wszystkie"
  'przenosimy arkusz Przydziały - wszystkie do BAŚKA   na koniec
  Windows(Askąd).Activate
  Sheets(Zskąd).Select
  'wyczyszczenie filtrów
  'Selection.AutoFilter
  Cells.Select
  'skopiowanie danych
  Selection.Copy
  'wklejenie danych
  Windows(Adokąd).Activate
  Sheets(Zdokąd).Select
  Range("A1").Select
  ActiveSheet.Paste
  'zamknięcie pliku - coś trzeba zrobić żeby nie pytało o nic
  Windows(Askąd).Activate
  'ActiveWindow.Close
  Application.CutCopyMode = False
  ActiveWorkbook.Close savechanges:=False
  Application.CutCopyMode = True
  Range("A1").Select
  Sheets("START").Select
End Sub

Sub PobierzPlikCENTRUM()
  Adokąd = ActiveWorkbook.Name
  Zdokąd = "centrum"
'wyczyszczenie poprzednich
  Sheets(Zdokąd).Select
  Cells.Select
  Selection.ClearContents
  'kolory
  Cells.Select
    With Selection.Interior
        .Pattern = xlNone
    End With
  Range("A1").Select
   
  Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
  plik = Application.FileDialog(msoFileDialogOpen).Show
  If plik <> 0 Then
    plik = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
  End If
  Workbooks.OpenText Filename:=plik, Origin:=1250 _
        , StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
        Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1)), _
        TrailingMinusNumbers:=True
  
  'plik otwarty
  'nazwa otwartego arkusza
  Askąd = ActiveWorkbook.Name
  'nazwa wybranej zakłądki w arkuszu
  Zskąd = ActiveSheet.Name
  'Zskąd = "Przydziały - wszystkie"
  'przenosimy arkusz Przydziały - wszystkie do BAŚKA   na koniec
  Windows(Askąd).Activate
  Sheets(Zskąd).Select
  'wyczyszczenie filtrów
  'Selection.AutoFilter
  Cells.Select
  'skopiowanie danych
  Selection.Copy
  'wklejenie danych
  Windows(Adokąd).Activate
  Sheets(Zdokąd).Select
  Range("A1").Select
  ActiveSheet.Paste
  'zamknięcie pliku - coś trzeba zrobić żeby nie pytało o nic
  Windows(Askąd).Activate
  'ActiveWindow.Close
  Application.CutCopyMode = False
  ActiveWorkbook.Close savechanges:=False
  Application.CutCopyMode = True
  Range("A1").Select
  'ustawienie kolumn
  Cells.Select
  Cells.EntireColumn.AutoFit
  Range("A1").Select
  Sheets("START").Select
End Sub