Cần sự giúp đỡ tạo Sheet tổng hợp (1 người xem)

[akuraqui]

Tình hình là e cần tổng hợp nhiều file dữ liệu khách hàng thành 1. Ae giúp cái code để có được sheet tổng hợp giống mẫu mẫu

 

[snow25]

Tình hình là e cần tổng hợp nhiều file dữ liệu khách hàng thành 1. Ae giúp cái code để có được sheet tổng hợp giống mẫu mẫu

Bạn xem code nhé.

Sub tonghop()
Dim arr, arr1, sh As Object, lr As Long, a As Long, j As Integer, i As Long
    ReDim arr1(1 To 10000, 1 To 11)
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TONGHOP" And sh.Visible = True Then
           lr = sh.Range("C" & Rows.Count).End(xlUp).Row
           If lr > 3 Then
              arr = sh.Range("A4:K" & lr).Value
              For i = 1 To UBound(arr, 1)
                  a = a + 1
                  arr1(a, 1) = a
                  For j = 2 To UBound(arr, 2)
                      arr1(a, j) = arr(i, j)
                  Next j
             Next i
         End If
      End If
   Next
   With Sheets("TONGHOP")
       lr = .Range("C" & Rows.Count).End(xlUp).Row
       If lr > 3 Then .Range("A4:K" & lr).ClearContents
       If a Then .Range("A4").Resize(a, 11).Value = arr1
   End With
End Sub

 

[vanthinh3101]

Tình hình là e cần tổng hợp nhiều file dữ liệu khách hàng thành 1. Ae giúp cái code để có được sheet tổng hợp giống mẫu mẫu

Gửi bạn tham khảo:

Sub Tonghop()
    Dim Cn As Object, Rst As Object, Ws As Worksheet
    Dim lR As Long, lR1 As Long, sql As String
    
    Set Cn = CreateObject("ADODB.Connection")
    Set Rst = CreateObject("ADODB.Recordset")
    
    With Cn
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
                      ";Extended Properties=""Excel 12.0 Xml;HDR=NO;"""
        .Open
    End With
    
    For Each Ws In ThisWorkbook.Sheets
        If Ws.Name <> "TONGHOP" And Ws.Name <> "H.DAN" Then
            'Tim dong trong dau tien tai Sheet("TONGHOP") de paste du lieu
            lR = Sheet2.Range("C" & Rows.Count).End(xlUp).Row + 1
            If lR < 4 Then lR = 4
            
            'Tim dong cuoi cung co du lieu
            lR1 = Ws.Range("C" & Rows.Count).End(xlUp).Row
            If lR1 >= 4 Then
                sql = "SELECT * FROM [" & Ws.Name & "$B4:K" & lR & "]"
                Set Rst = Cn.Execute(sql)
                Sheet2.Range("B" & lR).CopyFromRecordset Rst
            End If
        End If
    Next Ws
    
    Set Cn = Nothing: Set Rst = Nothing
    MsgBox "Done", vbInformation, "GPE"
End Sub

 

[Syn.nguyen]

Bạn dùng thử tool này đi xem, viết bằng delphi XE6 nhe:
Code như dưới đây:
procedure TForm4.Button1Click(Sender: TObject);
var
c,r,i,loop:integer;
begin
loop:=0;
for I := 1 to 4 do
begin
for r := 2 to XLSSpreadSheet1.XLS.Sheets.LastRow do
begin
if XLSSpreadSheet1.XLS.Sheets.AsString[2,r]<>'' then
begin
Inc(loop);
XLSSpreadSheet1.XLS.Sheets[0].AsString[0,loop+1]:=loop.ToString;
XLSSpreadSheet1.XLS.Sheets[0].AsString[2,loop+1]:=XLSSpreadSheet1.XLS.Sheets.AsString[2,r];
XLSSpreadSheet1.XLS.Sheets[0].AsString[3,loop+1]:=XLSSpreadSheet1.XLS.Sheets.AsString[3,r];
XLSSpreadSheet1.XLS.Sheets[0].AsString[8,loop+1]:=XLSSpreadSheet1.XLS.Sheets.AsString[8,r];
XLSSpreadSheet1.XLS.Sheets[0].AsString[10,loop+1]:=XLSSpreadSheet1.XLS.Sheets.AsString[10,r];
end;
end;
end;
XLSSpreadSheet1.InvalidateSheet;
Application.ProcessMessages;
end;

procedure TForm4.Button2Click(Sender: TObject);
var
_sTemp:string;
begin
if( SelectDirectory('Select Directory', '', _sTemp))then
begin
XLSSpreadSheet1.XLS.SaveToFile(_sTemp+'\NewFile'+FormatDateTime('yyyymmdd_hhnnss',Now)+'.xlsx');
end;
end;

procedure TForm4.FormShow(Sender: TObject);
begin
XLSSpreadSheet1.Filename := 'DEMO.xlsx';
XLSSpreadSheet1.Read;
XLSSpreadSheet1.InvalidateSheet;
Application.ProcessMessages;
end;

 

[akuraqui]

Gửi bạn tham khảo:

Sub Tonghop()
    Dim Cn As Object, Rst As Object, Ws As Worksheet
    Dim lR As Long, lR1 As Long, sql As String
  
    Set Cn = CreateObject("ADODB.Connection")
    Set Rst = CreateObject("ADODB.Recordset")
  
    With Cn
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
                      ";Extended Properties=""Excel 12.0 Xml;HDR=NO;"""
        .Open
    End With
  
    For Each Ws In ThisWorkbook.Sheets
        If Ws.Name <> "TONGHOP" And Ws.Name <> "H.DAN" Then
            'Tim dong trong dau tien tai Sheet("TONGHOP") de paste du lieu
            lR = Sheet2.Range("C" & Rows.Count).End(xlUp).Row + 1
            If lR < 4 Then lR = 4
          
            'Tim dong cuoi cung co du lieu
            lR1 = Ws.Range("C" & Rows.Count).End(xlUp).Row
            If lR1 >= 4 Then
                sql = "SELECT * FROM [" & Ws.Name & "$B4:K" & lR & "]"
                Set Rst = Cn.Execute(sql)
                Sheet2.Range("B" & lR).CopyFromRecordset Rst
            End If
        End If
    Next Ws
  
    Set Cn = Nothing: Set Rst = Nothing
    MsgBox "Done", vbInformation, "GPE"
End Sub

bạn có thể hỗ trợ mình thêm không?
Nó chỉ lấy mấy dòng thôi. mình nhập thêm dữ liệu nữa nhưng run nó không hiện
Và chọn Mã KH theo thứ tự tăng dần

Bài đã được tự động gộp: 19/2/19

Bạn dùng thử tool này đi xem, viết bằng delphi XE6 nhe:
Code như dưới đây:
procedure TForm4.Button1Click(Sender: TObject);
var
c,r,i,loop:integer;
begin
loop:=0;
for I := 1 to 4 do
begin
for r := 2 to XLSSpreadSheet1.XLS.Sheets.LastRow do
begin
if XLSSpreadSheet1.XLS.Sheets.AsString[2,r]<>'' then
begin
Inc(loop);
XLSSpreadSheet1.XLS.Sheets[0].AsString[0,loop+1]:=loop.ToString;
XLSSpreadSheet1.XLS.Sheets[0].AsString[2,loop+1]:=XLSSpreadSheet1.XLS.Sheets.AsString[2,r];
XLSSpreadSheet1.XLS.Sheets[0].AsString[3,loop+1]:=XLSSpreadSheet1.XLS.Sheets.AsString[3,r];
XLSSpreadSheet1.XLS.Sheets[0].AsString[8,loop+1]:=XLSSpreadSheet1.XLS.Sheets.AsString[8,r];
XLSSpreadSheet1.XLS.Sheets[0].AsString[10,loop+1]:=XLSSpreadSheet1.XLS.Sheets.AsString[10,r];
end;
end;
end;
XLSSpreadSheet1.InvalidateSheet;
Application.ProcessMessages;
end;

procedure TForm4.Button2Click(Sender: TObject);
var
_sTemp:string;
begin
if( SelectDirectory('Select Directory', '', _sTemp))then
begin
XLSSpreadSheet1.XLS.SaveToFile(_sTemp+'\NewFile'+FormatDateTime('yyyymmdd_hhnnss',Now)+'.xlsx');
end;
end;

procedure TForm4.FormShow(Sender: TObject);
begin
XLSSpreadSheet1.Filename := 'DEMO.xlsx';
XLSSpreadSheet1.Read;
XLSSpreadSheet1.InvalidateSheet;
Application.ProcessMessages;
end;

Cảm ơn bạn. nhưng đôi lúc mình có thêm bớt cột nên mình tìm hiểu thêm nhiều code khác

 

[vanthinh3101]

bạn có thể hỗ trợ mình thêm không?
Nó chỉ lấy mấy dòng thôi. mình nhập thêm dữ liệu nữa nhưng run nó không hiện
Và chọn Mã KH theo thứ tự tăng dần

Tôi bị nhầm 1 dòng, bạn sửa lại như sau:
Từ:

sql = "SELECT * FROM [" & Ws.Name & "$B4:K" & lR & "]"

Thành:

sql = "SELECT * FROM [" & Ws.Name & "$B4:K" & lR1 & "]"

Trường hợp bạn muốn sắp xếp theo thứ tụ tăng dần, tôi chưa nghĩ ra cách làm toàn bộ, mới nghĩ ra cách làm cho từng sheet thành phần khi tổng hợp vào thôi. Bạn sửa dòng lệnh sql thành:

sql = "SELECT * FROM [" & Ws.Name & "$B4:K" & lR1 & "] ORDER BY F2 ASC"

@Hai Lúa Miền Tây: xin nhờ anh xem giúp cho trường hợp sắp xếp theo yêu cầu của chủ thớt khi dùng SQL.