Solved

Compare of Excelsheets

Posted on 2014-02-12
41
361 Views
Last Modified: 2014-03-03
I'm not sure how I can explain this, for you guys to understand with my bad english.

I have a exceldoc with 3 sheets at the moment, in time this will increase. The name of the sheets is the date of the day it was created. If you see in the attachment the name of the sheets is: 2013-04-22, 2012-09-05, 2012-06-08 in that order.

2013-04-22 = A
2012-09-05 = B
2012-06-08 = C

I want to compare B with C. I want to delete records in C, if the username exists in both B and C. When the comparing is done I want to add the rest of sheet C to sheet B. Then I will do the same with A and B.

To connect to Excel I use this:
procedure TFrmMain.ConnectToExcel;
var strConn :  widestring;
begin
  strConn:='Provider=Microsoft.ACE.OLEDB.12.0;' +
          'Data Source=' + Edit6.Text + ';' +
          'Extended Properties="Excel 12.0 xml;HDR=YES";';
  AdoConnection1.Connected:=False;
  AdoConnection1.ConnectionString:=strConn;
  ADOConnection1.CursorLocation := clUseServer;
  ADOConnection1.LoginPrompt := false;
  ADOConnection1.Mode := cmShareDenyNone;
  ADOConnection1.Provider := 'Microsoft.ACE.OLEDB.12.0';
  try
    ADOConnection1.Open;
    ADOConnection1.GetTableNames(listbox2.Items,false);
  except
    ShowMessage('Unable to connect to Excel, make sure the workbook ' + Edit6.Text + ' exist!');
    raise;
  end;
end;

Open in new window


This is what I have tried to far, but I can not figure it out:

procedure TFrmMain.FetchData;
var strComputerNavn, strUserName, strXLSearchKey, strSearchForUsername, Target : string; OldExcelList, List, LineList : TStringList; I, x, y : Integer; UserFound : Boolean; strConn :  widestring;
begin
  List := TStringList.Create;
  OldExcelList := TStringList.Create;
  OldExcelList.Sorted := true;
  OldExcelList.duplicates := dupIgnore;
  NewExcelList := TStringList.Create;
  NewTestExcelList := TStringList.Create;
  StatusBar1.SimpleText := '';
  StatusBar2.Panels[0].Text := 'FetchData';
  if not checkbox1.Checked then
  begin
    if checkbox5.Checked then
    begin
      OldExcelList := TStringList.Create;
      OldExcelList.Sorted := true;
      OldExcelList.duplicates := dupIgnore;
      OldExcelList.Clear;
      for Y := 0 to listbox2.Count-1 do
      begin
        if pos('''', listbox2.Items.Strings[Y]) <> 0 then
          AdoQuery2.SQL.Text := 'SELECT * FROM ['+copy(Listbox2.Items.Strings[Y],2,pos('$',Listbox2.Items.Strings[Y])-1)+']'
        else
          AdoQuery2.SQL.Text := 'SELECT * FROM ['+Listbox2.Items.Strings[Y]+']';
        try
          AdoQuery2.Open;
          try
            ProgressBar2.Max := ListView2.Items.Count -1;
            for I := 0 to ListView2.Items.Count - 1 do
            begin
              ADOQuery2.First;
              userFound := false;
              OldExcelList.Clear;
              strSearchForUsername := copy(Listview2.Items.Item[I].SubItems.CommaText,1,pos(',',Listview2.Items.Item[I].SubItems.CommaText)-1);
              while not ADOQuery2.Eof do
              begin
                if pos(strSearchForUsername, UpperCase(ADOQuery2.FieldByName('User Name').AsString)) <> 0 then
                begin
                  OldExcelList.Add(UpperCase(AdoQuery2.FieldByName('Computer Name').AsString));
                  UserFound := true;
                end;
                ADOQuery2.Next;
              end;
              if UserFound then
              begin
                if pos(Listview2.Items.Item[I].Caption,OldExcelList.Text) <> 0 then
                begin
                  XLEndList.Add(Listview2.Items.Item[I].Caption + ',' + Listview2.Items.Item[I].SubItems.CommaText+ ',0');  // (Color: White) Same user
                end
                else
                begin
                  XLEndList.Add(Listview2.Items.Item[I].Caption + ',' + Listview2.Items.Item[I].SubItems.CommaText+ ',2');  // (Color: Green) same user, another computer
                end;
              end
              else
              begin
                XLEndList.Add(Listview2.Items.Item[I].Caption + ',' + Listview2.Items.Item[I].SubItems.CommaText+ ',1');    // (Color: Red) New User
              end;
            end;
          finally
            ADOQuery2.Close;
          end;
          ProgressBar2.Position := i;
          ProgressBar2.Update;
          Application.Processmessages;
        except
          ShowMessage('Unable to read data from Excel, make sure the query ' + AdoQuery2.SQL.Text + ' is meaningful!');
          raise;
        end;
      end;
    end;
    ProgressBar2.Position := 0;
  end
  else
  begin  // New document
    ProgressBar2.Max := ListView2.Items.Count -1;
    for I := 0 to ListView2.Items.Count - 1 do
    begin
      XLEndList.Add(Listview2.Items.Item[I].Caption + ',' + Listview2.Items.Item[I].SubItems.CommaText+ ',3');
      ProgressBar2.Position := i;
      ProgressBar2.Update;
      Application.Processmessages;
    end;
    ProgressBar2.Position := 0;
  end;
end;

Open in new window

Doc1.xlsx
0
Comment
Question by:QC20N
  • 15
  • 15
  • 10
41 Comments
 
LVL 19

Expert Comment

by:Thommy
ID: 39855861
Deleting records with an excel data connection is NOT possible!!! (Refer to section Deleting Rows on Accessing and managing MS Excel sheets with Delphi )

Try my solution...
 
procedure TFrmMain.CompareExcelSheets;
var
  i: integer;
  Name1,Name2: string;
begin
  for i := 0 to listbox1.Count-2 do begin

    AdoQuery1.Close;
    AdoQuery2.Close;

    if pos('''', listbox1.Items[i]) <> 0 then
      Name2:=copy(Listbox1.Items[i],2,pos('$',Listbox1.Items[i])-1)
    else
      Name2:=Listbox1.Items[i];
    AdoQuery2.SQL.Text := 'SELECT * FROM ['+Name2+']';
    AdoQuery2.Open;

    if pos('''', listbox1.Items[i+1]) <> 0 then
      Name1:=copy(Listbox1.Items[i+1],2,pos('$',Listbox1.Items[i+1])-1)
    else
      Name1:=Listbox1.Items[i+1];
    AdoQuery1.SQL.Text := 'SELECT * FROM ['+Name1+']';
    AdoQuery1.Open;

    AdoQuery2.First;
    while not AdoQuery2.eof do begin

      if not AdoQuery2.FieldByName('User Name').IsNull then begin

        AdoQuery1.Filter:='[User Name] = '''+AdoQuery2.FieldByName('User Name').Asstring+'''';
        if AdoQuery1.FindFirst then begin
//Deleting rows in Excel with a TAdoConnection is NOT possible.
//Therefore I set fields to empty strings
          AdoQuery2.Edit;
          AdoQuery2.FieldByName('Computer Name').AsString:='';
          AdoQuery2.FieldByName('User Name').AsString    :='';
          AdoQuery2.Post;
        end
        else begin
          AdoQuery1.Filter:='';
          AdoQuery1.insert;
          AdoQuery1.FieldByName('Computer Name').asstring := AdoQuery2.FieldByName('Computer Name').asstring;
          AdoQuery1.FieldByName('User Name').asstring     := AdoQuery2.FieldByName('User Name').asstring;
          AdoQuery1.post;
        end;
      end;

      AdoQuery2.Next;
    end;

  end;

end;

Open in new window

0
 
LVL 45

Expert Comment

by:aikimark
ID: 39856165
@QC20N

Looking at the data in your workbook,  I would like a better understanding of the red (background) cells.  In the 2012-06-08 worksheet, the SELUALP AND SETUJBM user names are in red, however, I don't see those user names in the 2012-09-05 worksheet.  Does the red color mean that those rows should be deleted?

While the database (joined table) query approach can be used to find the matches, you will need to use Excel automation to do the row deletion.
0
 

Author Comment

by:QC20N
ID: 39856257
Please, disregard the colors in the attachment.

That is just for internal use. :)

If SELUALP and SETUJBM does not exists in the 2012-09-05 worksheet, then it should not be deleted. The goal is to have Sheet A to be the most correct one, but it has to contain the rest of info from the other sheets. For exampel Sheets B need to contain the rest of sheet C before comparing A with B.

As you can see in C there is a record, but that will be deleted and the record with the same username in B will be saved.

C:
SELULT3043      SELUJNNE

B after comparing with C

SELULT3467      SELUALP
SETULT0998      SETUJBM
SELULT2741      SELUSONA
SELUDT2599      SELUG013
SELUDT2634      SELUKLHX
SELULT3166      SELUHANC
SETULT1106      SETUBFG
SELULT3167      SELUJNNE

A after comparing with B

SELULT3467      SELUALP
SETULT0998      SETUJBM
SELUDT2599      SELUG013
SELUDT2634      SELUKLHX
SEESLT0096      SEESPSO
SELULT3166      SELUHANC
SELULT2741      SELUSONA
SETULT1106      SETUBFG
SELULT3167      SELUJNNE
0
 
LVL 19

Expert Comment

by:Thommy
ID: 39856308
Have you already tried my code?
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39856399
What will be the contents of worksheet B after the comparison and data transfer operation with worksheet A?

I think I better understand what you are doing.  You are merging data.  However, I don't understand why you are deleting rows.
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39856457
More questions:
* Will the worksheets always appear in descending date order?
* Does this solution need to be in Delphi or have you considered a VBA solution?
0
 

Author Comment

by:QC20N
ID: 39856537
@aikimark.
It is true that I just want to merge data. I was not sure how I should explain it. Sorry about that.

The data of the original sheets need to be intact.

I need it in delphi.

@Tommy.
Not yet, but I will soon.
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39856578
My question was whether the worksheets would be in the descending date order when the merging code starts.  The code would simpler if that is a valid assumption.  Otherwise, the code would need to iterate the worksheet names and sort the names.

I still don't understand why you are deleting rows.

If you add a module to your workbook and add the following code in the module, you should be able to invoke the routine from your Delphi application.
Public Sub Q_28363030()
    Dim lngLoop As Long
    Dim wksSrc As Worksheet
    Dim wksTgt As Worksheet
    Dim rngTgt As Range
    Dim rngCell As Range
    Dim lngRow As Long
    'const xlDown as Long = -4121
    Application.ScreenUpdating = False
    For lngLoop = Worksheets.Count To 2 Step -1
        Set wksSrc = Worksheets(lngLoop)
        Set wksTgt = Worksheets(lngLoop - 1)
        Set rngTgt = wksTgt.Range("A1").End(xlDown).Offset(1)
        wksSrc.UsedRange.AdvancedFilter action:=xlFilterInPlace, criteriarange:=wksTgt.Range(wksTgt.Range("B1"), wksTgt.Range("B1").End(xlDown))
        For lngRow = wksSrc.Range("B2").End(xlDown).Row To 2 Step -1
            Set rngCell = wksSrc.Cells(lngRow, 2)
            If rngCell.EntireRow.Hidden Then
                rngTgt.EntireRow.Value = rngCell.EntireRow.Value
                Set rngTgt = rngTgt.Offset(1)
            Else
                rngCell.EntireRow.Delete
            End If
        Next
        wksSrc.ShowAllData
    Next
    Application.ScreenUpdating = True
End Sub

Open in new window

If that isn't possible/desirable, you might rewrite the VBA code in Delphi.  The Application variable in the VBA would be an Excel application object.
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39856589
Also, the Delphi code would need to open the workbook in order to instantiate the worksheet and range object variables.
0
 

Author Comment

by:QC20N
ID: 39856600
Yes, the worksheets always appear in descending date order.

I think I have explain this wrong. I do not need to delete the rows.

I am, as you said, just merging data.
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39856644
If you aren't deleting the rows, then this code should do the non-deleting merge.
Public Sub Q_28363030()
    Dim lngLoop As Long
    Dim wksSrc As Worksheet
    Dim wksTgt As Worksheet
    Dim rngTgt As Range
    Dim rngCell As Range
    Dim lngRow As Long
    'const xlDown as Long = -4121
    Application.ScreenUpdating = False
    For lngLoop = Worksheets.Count To 2 Step -1
        Set wksSrc = Worksheets(lngLoop)
        Set wksTgt = Worksheets(lngLoop - 1)
        Set rngTgt = wksTgt.Range("A1").End(xlDown).Offset(1)
        wksSrc.UsedRange.AdvancedFilter action:=xlFilterInPlace, criteriarange:=wksTgt.Range(wksTgt.Range("B1"), wksTgt.Range("B1").End(xlDown))
        For lngRow = wksSrc.Range("B2").End(xlDown).Row To 2 Step -1
            Set rngCell = wksSrc.Cells(lngRow, 2)
            If rngCell.EntireRow.Hidden Then
                rngTgt.EntireRow.Value = rngCell.EntireRow.Value
                Set rngTgt = rngTgt.Offset(1)
            End If
        Next
        wksSrc.ShowAllData
    Next
    Application.ScreenUpdating = True
End Sub

Open in new window

0
 
LVL 19

Expert Comment

by:Thommy
ID: 39858234
Hi QC20N,

this is an updated version of my previous code, which eliminates empty rows in your excel sheets...

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,VCL.OleAuto, Excel2000,
  Vcl.OleServer, Data.DB, Datasnap.DBClient, Data.Win.ADODB;

type
  TFrmMain = class(TForm)
    ListBox1: TListBox;
    BtnADOCompareExcelSheets: TButton;
    ADOConnection1: TADOConnection;
    ADOQuery1: TADOQuery;
    ADOQuery2: TADOQuery;
    BtnADOConnectXLS: TButton;
    procedure BtnADOCompareExcelSheetsClick(Sender: TObject);
    procedure BtnADOConnectXLSClick(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }

     slSheets: TStringList;

     procedure GetSheetsList;
     procedure ClearSheetsList;
     procedure CompareExcelSheets;
     procedure EliminateEmptyRows;
  end;

  TXLSRecord= Record
    ComputerName: string;
    UserName    : string;
  End;

  TXLSRecords = array of TXLSRecord;

var
  FrmMain: TFrmMain;

implementation

{$R *.dfm}

procedure TFrmMain.GetSheetsList;
var
  i:integer;
begin
  slSheets:=TStringList.Create;
  for i:=0 to listbox1.Count-1 do begin
    if pos('''', listbox1.Items[i]) <> 0 then
      slSheets.Add(copy(Listbox1.Items[i],2,pos('$',Listbox1.Items[i])-1))
    else
      slSheets.Add(ListBox1.Items[i]);
  end;
end;

procedure TFrmMain.ClearSheetsList;
begin
  slSheets.Clear;
  FreeAndNil(slSheets);
end;

procedure TFrmMain.CompareExcelSheets;
var
  i: integer;
//  Name1,Name2: string;
begin
  for i := 0 to listbox1.Count-2 do begin

    AdoQuery1.Close;
    AdoQuery2.Close;

    AdoQuery2.SQL.Text := 'SELECT * FROM ['+slSheets[i]+']';
    AdoQuery2.Open;

    AdoQuery1.SQL.Text := 'SELECT * FROM ['+slSheets[i+1]+']';
    AdoQuery1.Open;

    AdoQuery2.First;

    while not AdoQuery2.eof do begin

      if not AdoQuery2.FieldByName('User Name').IsNull then begin

        AdoQuery1.Filter:='[User Name] = '''+AdoQuery2.FieldByName('User Name').Asstring+'''';
        if AdoQuery1.FindFirst then begin
//Deleting rows in Excel with a TAdoConnection is NOT possible.
//Therefore I set fields to empty strings
          AdoQuery2.Edit;
          AdoQuery2.FieldByName('Computer Name').AsString:='';
          AdoQuery2.FieldByName('User Name').AsString    :='';
          AdoQuery2.Post;
        end
        else begin
          AdoQuery1.Filter:='';
          AdoQuery1.insert;
          AdoQuery1.FieldByName('Computer Name').asstring := AdoQuery2.FieldByName('Computer Name').asstring;
          AdoQuery1.FieldByName('User Name').asstring     := AdoQuery2.FieldByName('User Name').asstring;
          AdoQuery1.post;
        end;
      end;

      AdoQuery2.Next;
    end;

  end;

  AdoQuery1.Filter:='';
  AdoQuery2.Filter:='';
end;

procedure TFrmMain.EliminateEmptyRows;
var
  i,j:integer;
  XLSRecords: TXLSRecords;
begin
  for i := 0 to listbox1.Count-2 do begin
    SetLength(XLSRecords,0);
    AdoQuery1.Close;
    AdoQuery1.SQL.Text := 'SELECT * FROM ['+slSheets[i]+']';
    AdoQuery1.Open;
    
    //collect all rows with data into dynamic array XLSRecords (field "User Name" <> '') 
    j:=0;
    AdoQuery1.First;
    SetLength(XLSRecords,AdoQuery1.RecordCount);
    while Not AdoQuery1.eof do begin
      if AdoQuery1.FieldByName('User Name').AsString<>'' then begin
        XLSRecords[j].ComputerName:=AdoQuery1.FieldByName('Computer Name').AsString;
        XLSRecords[j].UserName    :=AdoQuery1.FieldByName('User Name').AsString;
        inc(j);
      end;
      AdoQuery1.Next;
    end;

    //Write XLSRecords data  back to sheet
    AdoQuery1.First;
    for j:=0 to High(XLSRecords) do begin

      AdoQuery1.Edit;
      AdoQuery1.FieldByName('Computer Name').AsString:=XLSRecords[j].ComputerName;
      AdoQuery1.FieldByName('User Name').AsString    :=XLSRecords[j].UserName;
      AdoQuery1.Post;

      AdoQuery1.Next;
    end;

  end;
  SetLength(XLSRecords,0);
end;

procedure TFrmMain.BtnADOConnectXLSClick(Sender: TObject);
var strConn :  widestring;
begin

  strConn:='Provider=Microsoft.ACE.OLEDB.12.0;' +
          'Data Source=' + 'D:\DXE\src\EE\CompareExcelSheets\Doc1.xlsx' + ';' +
          'Extended Properties="Excel 12.0 xml;HDR=YES";';
  AdoConnection1.Connected:=False;
  AdoConnection1.ConnectionString:=strConn;
  ADOConnection1.CursorLocation := clUseServer;
  ADOConnection1.LoginPrompt := false;
  ADOConnection1.Mode := cmShareDenyNone;
  ADOConnection1.Provider := 'Microsoft.ACE.OLEDB.12.0';
  try
    ADOConnection1.Open;
    ADOConnection1.GetTableNames(listbox1.Items,false);
  except
    ShowMessage('Unable to connect to Excel, make sure the workbook ' + 'D:\DXE\src\EE\CompareExcelSheets\Doc1.xlsx' + ' exist!');
    raise;
  end;

  AdoQuery1.CursorLocation:=clUseServer;
  AdoQuery2.CursorLocation:=clUseServer;
end;

procedure TFrmMain.BtnADOCompareExcelSheetsClick(Sender: TObject);
begin
  GetSheetsList;
  CompareExcelSheets;
  EliminateEmptyRows;
  ClearSheetsList;
end;

end.

Open in new window

Please let me know in case of any problems or questions...
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39858288
One more method that can be used is to populate an ADO recordset object with the records from the older worksheet, not matched in the newer worksheet, and then use the .CopyFromRecordset method of an Excel range object to transfer the data to the newer worksheet.  This process would be repeated for the adjacent worksheets, from oldest to newest.
0
 

Author Comment

by:QC20N
ID: 39858449
@Thommy:

I get an error:

"Either BOF or EOF is True..."

Please, see attachment

Please, have in mind that is not necessary to delete rows in the sheets.
Capture.JPG
0
 
LVL 19

Expert Comment

by:Thommy
ID: 39858468
I think you've missed to set CursorLocation:=clUseServer for both instances of TAdoQuery...

Have a look at the last 2 lines of my procedure BtnADOConnectXLSClick...
procedure TFrmMain.BtnADOConnectXLSClick(Sender: TObject);
var strConn :  widestring;
begin

  strConn:='Provider=Microsoft.ACE.OLEDB.12.0;' +
          'Data Source=' + 'D:\DXE\src\EE\CompareExcelSheets\Doc1.xlsx' + ';' +
          'Extended Properties="Excel 12.0 xml;HDR=YES";';
  AdoConnection1.Connected:=False;
  AdoConnection1.ConnectionString:=strConn;
  ADOConnection1.CursorLocation := clUseServer;
  ADOConnection1.LoginPrompt := false;
  ADOConnection1.Mode := cmShareDenyNone;
  ADOConnection1.Provider := 'Microsoft.ACE.OLEDB.12.0';
  try
    ADOConnection1.Open;
    ADOConnection1.GetTableNames(listbox1.Items,false);
  except
    ShowMessage('Unable to connect to Excel, make sure the workbook ' + 'D:\DXE\src\EE\CompareExcelSheets\Doc1.xlsx' + ' exist!');
    raise;
  end;

  AdoQuery1.CursorLocation:=clUseServer;
  AdoQuery2.CursorLocation:=clUseServer;
end;

Open in new window

0
 

Author Comment

by:QC20N
ID: 39858494
I did a copy 'n'  paste.
0
 
LVL 19

Expert Comment

by:Thommy
ID: 39858592
Set property cursorlocation to clUseServer for TAdoConnection and TAdoQuery at design time...

I have tested it and everything works fine at my site. Please see results in attached pdf file...
XLS-Results.pdf
0
 

Author Comment

by:QC20N
ID: 39858633
Sorry.
Same problem.
0
 
LVL 19

Expert Comment

by:Thommy
ID: 39858650
Please tell me your Excel version and post your code...
0
 

Author Comment

by:QC20N
ID: 39858666
Excel 2010

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Data.DB, Data.Win.ADODB, Vcl.StdCtrls;

type
  TFrmMain = class(TForm)
    ListBox1: TListBox;
    BtnADOCompareExcelSheets: TButton;
    ADOConnection1: TADOConnection;
    ADOQuery1: TADOQuery;
    ADOQuery2: TADOQuery;
    BtnADOConnectXLS: TButton;
    procedure BtnADOConnectXLSClick(Sender: TObject);
    procedure BtnADOCompareExcelSheetsClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
     slSheets: TStringList;

     procedure GetSheetsList;
     procedure ClearSheetsList;
     procedure CompareExcelSheets;
     procedure EliminateEmptyRows;
  end;

  TXLSRecord= Record
    ComputerName: string;
    UserName    : string;
  End;

  TXLSRecords = array of TXLSRecord;


var
  FrmMain: TFrmMain;

implementation

{$R *.dfm}

procedure TFrmMain.GetSheetsList;
var
  i:integer;
begin
  slSheets:=TStringList.Create;
  for i:=0 to listbox1.Count-1 do begin
    if pos('''', listbox1.Items[i]) <> 0 then
      slSheets.Add(copy(Listbox1.Items[i],2,pos('$',Listbox1.Items[i])-1))
    else
      slSheets.Add(ListBox1.Items[i]);
  end;
end;

procedure TFrmMain.BtnADOCompareExcelSheetsClick(Sender: TObject);
begin
  GetSheetsList;
  CompareExcelSheets;
  EliminateEmptyRows;
  ClearSheetsList;
end;

procedure TFrmMain.BtnADOConnectXLSClick(Sender: TObject);
var strConn :  widestring;
begin

  strConn:='Provider=Microsoft.ACE.OLEDB.12.0;' +
          'Data Source=' + 'path\Doc1.xlsx' + ';' +
          'Extended Properties="Excel 12.0 xml;HDR=YES";';
  AdoConnection1.Connected:=False;
  AdoConnection1.ConnectionString:=strConn;
  ADOConnection1.CursorLocation := clUseServer;
  ADOConnection1.LoginPrompt := false;
  ADOConnection1.Mode := cmShareDenyNone;
  ADOConnection1.Provider := 'Microsoft.ACE.OLEDB.12.0';
  try
    ADOConnection1.Open;
    ADOConnection1.GetTableNames(listbox1.Items,false);
  except
    ShowMessage('Unable to connect to Excel, make sure the workbook ' + 'D:\DXE\src\EE\CompareExcelSheets\Doc1.xlsx' + ' exist!');
    raise;
  end;
//  ADOConnection1.LoginPrompt := false;
  AdoQuery1.Connection := AdoConnection1;
  AdoQuery2.Connection := AdoConnection1;
  AdoQuery1.CursorLocation:=clUseServer;
  AdoQuery2.CursorLocation:=clUseServer;
end;

procedure TFrmMain.ClearSheetsList;
begin
  slSheets.Clear;
  FreeAndNil(slSheets);
end;

procedure TFrmMain.CompareExcelSheets;
var
  i: integer;
//  Name1,Name2: string;
begin
  for i := 0 to listbox1.Count-2 do begin

    AdoQuery1.Close;
    AdoQuery2.Close;

    AdoQuery2.SQL.Text := 'SELECT * FROM ['+slSheets[i]+']';
    AdoQuery2.Open;

    AdoQuery1.SQL.Text := 'SELECT * FROM ['+slSheets[i+1]+']';
    AdoQuery1.Open;

    AdoQuery2.First;

    while not AdoQuery2.eof do begin

      if not AdoQuery2.FieldByName('User Name').IsNull then begin

        AdoQuery1.Filter:='[User Name] = '''+AdoQuery2.FieldByName('User Name').Asstring+'''';
        if AdoQuery1.FindFirst then begin
//Deleting rows in Excel with a TAdoConnection is NOT possible.
//Therefore I set fields to empty strings
          AdoQuery2.Edit;
          AdoQuery2.FieldByName('Computer Name').AsString:='';
          AdoQuery2.FieldByName('User Name').AsString    :='';
          AdoQuery2.Post;
        end
        else begin
          AdoQuery1.Filter:='';
          AdoQuery1.insert;
          AdoQuery1.FieldByName('Computer Name').asstring := AdoQuery2.FieldByName('Computer Name').asstring;
          AdoQuery1.FieldByName('User Name').asstring     := AdoQuery2.FieldByName('User Name').asstring;
          AdoQuery1.post;
        end;
      end;

      AdoQuery2.Next;
    end;

  end;

  AdoQuery1.Filter:='';
  AdoQuery2.Filter:='';
end;

procedure TFrmMain.EliminateEmptyRows;
var
  i,j:integer;
  XLSRecords: TXLSRecords;
begin
  for i := 0 to listbox1.Count-2 do begin
    SetLength(XLSRecords,0);
    AdoQuery1.Close;
    AdoQuery1.SQL.Text := 'SELECT * FROM ['+slSheets[i]+']';
    AdoQuery1.Open;

    //collect all rows with data into dynamic array XLSRecords (field "User Name" <> '')
    j:=0;
    AdoQuery1.First;
    SetLength(XLSRecords,AdoQuery1.RecordCount);
    while Not AdoQuery1.eof do begin
      if AdoQuery1.FieldByName('User Name').AsString<>'' then begin
        XLSRecords[j].ComputerName:=AdoQuery1.FieldByName('Computer Name').AsString;
        XLSRecords[j].UserName    :=AdoQuery1.FieldByName('User Name').AsString;
        inc(j);
      end;
      AdoQuery1.Next;
    end;

    //Write XLSRecords data  back to sheet
    AdoQuery1.First;
    for j:=0 to High(XLSRecords) do begin

      AdoQuery1.Edit;
      AdoQuery1.FieldByName('Computer Name').AsString:=XLSRecords[j].ComputerName;
      AdoQuery1.FieldByName('User Name').AsString    :=XLSRecords[j].UserName;
      AdoQuery1.Post;

      AdoQuery1.Next;
    end;

  end;
  SetLength(XLSRecords,0);
end;
end.

Open in new window

0
How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

 
LVL 19

Expert Comment

by:Thommy
ID: 39859086
Ok, I'm also using Excel 2010 and Delphi RAD Studio XE3.

Maybe you're using a different Delphi version?
What is your Delphi version???

Don't know the cause of the error, but you may try it without setting fields to empty strings. Comment out the appropriate lines and also comment out calling EliminateEmptyRows in procedure BtnADOCompareExcelSheetsClick...

procedure TFrmMain.BtnADOCompareExcelSheetsClick(Sender: TObject);
begin
  GetSheetsList;
  CompareExcelSheets;
  //EliminateEmptyRows;
  ClearSheetsList;
end;

...

procedure TFrmMain.CompareExcelSheets;
var
  i: integer;
begin
  for i := 0 to listbox1.Count-2 do begin

    AdoQuery1.Close;
    AdoQuery2.Close;

    AdoQuery2.SQL.Text := 'SELECT * FROM ['+slSheets[i]+']';
    AdoQuery2.Open;

    AdoQuery1.SQL.Text := 'SELECT * FROM ['+slSheets[i+1]+']';
    AdoQuery1.Open;

    AdoQuery2.First;

    while not AdoQuery2.eof do begin

      if not AdoQuery2.FieldByName('User Name').IsNull then begin

        AdoQuery1.Filter:='[User Name] = '''+AdoQuery2.FieldByName('User Name').Asstring+'''';
        if AdoQuery1.FindFirst then begin
//Deleting rows in Excel with a TAdoConnection is NOT possible.
//Therefore I set fields to empty strings

//          AdoQuery2.Edit;
//          AdoQuery2.FieldByName('Computer Name').AsString:='';
//          AdoQuery2.FieldByName('User Name').AsString    :='';
//          AdoQuery2.Post;

        end
        else begin
          AdoQuery1.Filter:='';
          AdoQuery1.insert;
          AdoQuery1.FieldByName('Computer Name').asstring := AdoQuery2.FieldByName('Computer Name').asstring;
          AdoQuery1.FieldByName('User Name').asstring     := AdoQuery2.FieldByName('User Name').asstring;
          AdoQuery1.post;
        end;
      end;

      AdoQuery2.Next;
    end;

  end;

  AdoQuery1.Filter:='';
  AdoQuery2.Filter:='';
end;

Open in new window

0
 

Author Comment

by:QC20N
ID: 39859091
Delphi XE2


I get the same error.

:(
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39859497
Try adding a dollar sign after the worksheet name.
Example:
'SELECT * FROM ['+slSheets[i]+'$]';

Open in new window

0
 
LVL 19

Expert Comment

by:Thommy
ID: 39860808
I don't have XE2!!!!
But I will check with XE, if I can reproduce the error....
0
 
LVL 19

Expert Comment

by:Thommy
ID: 39864008
OK, I have compiled and tested with Delphi XE.
No errors, every works fine as before with XE3!!!

So let's compare design time properties for TADoConnection and TAdoQueries to see if there could be any cause for the error...
TADODesignTimeProperties.pdf
0
 
LVL 19

Expert Comment

by:Thommy
ID: 39894029
Any updates in this case???
0
 

Author Comment

by:QC20N
ID: 39894214
Yes, sorry. I had a vacation here in Denmark.

I tried adding a $ sign, but I got the Capture3.jpg attachment error.

Followed TADODesignTimeProperties.pdf. I get the same error http://www.experts-exchange.com/Programming/Languages/Pascal/Delphi/Q_28363030.html#a39858449
Capture3.JPG
0
 

Author Comment

by:QC20N
ID: 39894234
I think I missed your attachment in :
Link

and your result is correct on the first TAB "2013-04-22"

I know I wanted that you should delete the records when you run it, but that was before I knew what I really wanted. You should not delete the records. I want the sheets intact, but if you could save the end result in a commaseparated list. It will be good.
0
 
LVL 19

Expert Comment

by:Thommy
ID: 39894627
Do you want all sheets/tabs intact and only have the end result saved in a csv file?
0
 

Author Comment

by:QC20N
ID: 39894839
Yes, please.
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39894945
It looks like there are two dollar signs.
0
 
LVL 19

Expert Comment

by:Thommy
ID: 39894999
@aikimark
Yes, there are 2 dollar signs
Adding a dollar sign as you suggested in one of your previous posts does not solve the problem at all...
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39895010
@Thommy

I didn't realize there was already a trailing $
(insert your favorite "follow the money" quote/joke here)
:-)
0
 
LVL 19

Accepted Solution

by:
Thommy earned 500 total points
ID: 39897198
Try this solution completely based on dynamic arrays.

All sheets stay untouched and result is written to comma separated file results.csv (see attached file)...
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics,
  Controls, Forms, Dialogs, StdCtrls,OleAuto, Excel2000,
  OleServer, DB, DBClient, ADODB;

type
  TXLSRecord= Record
    ComputerName: string;
    UserName    : string;
  End;

  TXLSRecords = array of TXLSRecord;
  TSheetsData = array of TXLSRecords;

  TFrmMain = class(TForm)
    ListBox1: TListBox;
    BtnADOCompareExcelSheets: TButton;
    ADOConnection1: TADOConnection;
    ADOQuery1: TADOQuery;
    ADOQuery2: TADOQuery;
    BtnADOConnectXLS: TButton;
    procedure BtnADOCompareExcelSheetsClick(Sender: TObject);
    procedure BtnADOConnectXLSClick(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }

     slSheets: TStringList;

     procedure GetSheetsList;
     procedure GetSheetsData;
     procedure ShowSheetsData;
     procedure ClearSheetsList;
     procedure CompareSheetsData;
     function IndexOfUserName(aSheetsData:TXLSRecords;aUserName:string):integer;
     procedure WriteResultFile;
     procedure WriteResultsToListBox;
  end;

var
  FrmMain: TFrmMain;
  SheetsData: TSheetsData;

implementation

{$R *.dfm}

procedure TFrmMain.GetSheetsList;
var
  i:integer;
begin
  slSheets:=TStringList.Create;
  for i:=0 to listbox1.Count-1 do begin
    if pos('''', listbox1.Items[i]) <> 0 then
      slSheets.Add(copy(Listbox1.Items[i],2,pos('$',Listbox1.Items[i])-1))
    else
      slSheets.Add(ListBox1.Items[i]);
  end;
  SetLength(SheetsData,slSheets.Count);
end;

procedure TFrmMain.GetSheetsData;
var
  i,j: integer;
begin
  for i := 0 to listbox1.Count-1 do begin
    SetLength(SheetsData[i],0);

    AdoQuery1.Close;
    AdoQuery1.SQL.Text := 'SELECT * FROM ['+slSheets[i]+']';
    AdoQuery1.Open;

    j:=0;
    AdoQuery1.First;
    SetLength(SheetsData[i],AdoQuery1.RecordCount);
    while not AdoQuery1.eof do begin
      SheetsData[i][j].ComputerName:=AdoQuery1.FieldByName('Computer Name').AsString;
      SheetsData[i][j].UserName    :=AdoQuery1.FieldByName('User Name').AsString;

      inc(j);
      AdoQuery1.Next;
    end;
  end;
end;

procedure TFrmMain.ShowSheetsData;
var
  i,j: integer;
begin
  for i:=0 to High(SheetsData) do begin
    for j:=0 to high(SheetsData[i]) do begin
      ShowMessage(slSheets[i]+#10+
                  'SheetsData['+inttostr(j)+'].ComputerName='+SheetsData[i][j].ComputerName+#10+
                  'SheetsData['+inttostr(j)+'].UserName='+SheetsData[i][j].UserName);
    end;
  end;
end;

procedure TFrmMain.ClearSheetsList;
var
  i: integer;
begin
  slSheets.Clear;
  FreeAndNil(slSheets);
  for i:=0 to high(SheetsData) do begin
    SetLength(SheetsData[i],0);
  end;
  SetLength(SheetsData,0);
end;

function TFrmMain.IndexOfUserName(aSheetsData:TXLSRecords;aUserName:string):integer;
var
  i: integer;
begin
  result:=-1;
  for i:=0 to High(aSheetsData) do begin
    if aSheetsData[i].UserName=aUserName then begin
      result:=i;
      break;
    end;
  end;
end;

procedure TFrmMain.CompareSheetsData;
var
  i,j,idx:integer;
begin
  for i := 0 to listbox1.Count-2 do begin
    for j:=0 to High(SheetsData[i]) do begin
      idx:=IndexOfUserName(SheetsData[i+1],SheetsData[i][j].UserName);
      if idx<0 then begin
        SetLength(SheetsData[i+1],Length(SheetsData[i+1])+1);

        SheetsData[i+1][High(SheetsData[i+1])].ComputerName:=SheetsData[i][j].ComputerName;

        SheetsData[i+1][High(SheetsData[i+1])].UserName    :=SheetsData[i][j].UserName;
      end;

    end;
  end;
end;

procedure TFrmMain.BtnADOConnectXLSClick(Sender: TObject);
var strConn :  widestring;
begin
strConn := 'Provider=Microsoft.Jet.OLEDB.4.0;' +
         'Provider=Microsoft.Jet.OLEDB.4.0; ' +
         'Data Source=' + 'D:\DXE\src\EE\CompareExcelSheets\Doc1.xls' + ';' +
         'Extended Properties=Excel 8.0; ' +
         'Persist Security Info=False';
//  strConn:='Provider=Microsoft.ACE.OLEDB.12.0;' +
//          'Data Source=' + 'D:\DXE\src\EE\CompareExcelSheets\Doc1.xlsx' + ';' +
//          'Extended Properties="Excel 12.0 xml;HDR=YES";';
  AdoConnection1.Connected:=False;
  AdoConnection1.ConnectionString:=strConn;
  ADOConnection1.CursorLocation := clUseServer;
  ADOConnection1.LoginPrompt := false;
  ADOConnection1.Mode := cmShareDenyNone;
  ADOConnection1.Provider := 'Microsoft.JET.OLEDB.4.0';
  try
    ADOConnection1.Open;
    ADOConnection1.GetTableNames(listbox1.Items,false);
  except
    ShowMessage('Unable to connect to Excel, make sure the workbook ' + 'D:\DXE\src\EE\CompareExcelSheets\Doc1.xlsx' + ' exist!');
    raise;
  end;

  AdoQuery1.CursorLocation:=clUseServer;
  AdoQuery2.CursorLocation:=clUseServer;
end;

procedure TFrmMain.BtnADOCompareExcelSheetsClick(Sender: TObject);
begin
  GetSheetsList;
  GetSheetsData;
  CompareSheetsData;
//  ShowSheetsData;
  WriteResultFile;
  WriteResultsToListBox;
  ClearSheetsList;
end;

procedure TFrmMain.WriteResultFile;
var
  r: textfile;
  j: integer;
begin
  AssignFile(r,'Results.csv');
  Rewrite(r);

  for j:=0 to High(SheetsData[High(SheetsData)]) do begin
    with SheetsData[High(SheetsData)][j] do
      writeln(r,ComputerName+','+UserName);
  end;
  Closefile(r);
end;

procedure TFrmMain.WriteResultsToListBox;
begin
  ListBox1.Items.LoadFromFile('Results.csv');
end;


end.

Open in new window

Results.csv
0
 

Author Comment

by:QC20N
ID: 39899837
Yes, it is working. Thank you very much. I tested it with the attach file and I could see in the endresult some "comma". Could that be deleted?

I would like to ask a small change to the code. If you see in the attachment there is a lot of sheets and some of the sheets has the wrong date format.

The wrong dateformat is MM-DD-YEAR
The right dateformat should be YEAR-MM-DD

The right dateformat is not to be saved in the exceldoc, but should be converted before it is added to the listbox.

Will that be possible?
Project-Pro-SE---Copy.xlsx
0
 
LVL 19

Expert Comment

by:Thommy
ID: 39900092
Yes, that's all possible.
But you're pushing my good nature to the limits!!!!
0
 

Author Comment

by:QC20N
ID: 39900101
I could make a new task on this so you can get more points. ok? :)
0
 

Author Comment

by:QC20N
ID: 39900588
0
 
LVL 19

Expert Comment

by:Thommy
ID: 39902540
Thank you very much for the points!!!

I really would have liked to help you wih your follow up question, but I didn't have much time yesterday and now I'm too late...
0
 

Author Comment

by:QC20N
ID: 39902560
That is ok. :)
0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Objective: - This article will help user in how to convert their numeric value become words. How to use 1. You can copy this code in your Unit as function 2. than you can perform your function by type this code The Code   (CODE) The Im…
Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
Here's a very brief overview of the methods PRTG Network Monitor (https://www.paessler.com/prtg) offers for monitoring bandwidth, to help you decide which methods you´d like to investigate in more detail.  The methods are covered in more detail in o…
You have products, that come in variants and want to set different prices for them? Watch this micro tutorial that describes how to configure prices for Magento super attributes. Assigning simple products to configurable: We assigned simple products…

706 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now