Cần sự giúp đỡ tạo Sheet tổng hợp

Liên hệ QC
A

akuraqui

Thành viên mới
Tham gia
20/11/13
Bài viết
2
Được thích
0
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
 

File đính kèm

  • VD.xlsx
    21.1 KB · Đọc: 24
akuraqui đã viết:
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
Nhấp chuột vào đây để mở rộng...
Bạn xem code nhé.
Mã: 
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
 
akuraqui đã viết:
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
Nhấp chuột vào đây để mở rộng...
Gửi bạn tham khảo:
PHP: 
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 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;
 

File đính kèm

  • Demotonghopfile.zip
    2.5 MB · Đọc: 8
vanthinh3101 đã viết:
Gửi bạn tham khảo:
PHP: 
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
Nhấp chuột vào đây để mở rộng...
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:

Syn.nguyen đã viết:
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;
Nhấp chuột vào đây để mở rộng...
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
 
Lần chỉnh sửa cuối:
akuraqui đã viết:
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
Nhấp chuột vào đây để mở rộng...
Tôi bị nhầm 1 dòng, bạn sửa lại như sau:
Từ:
PHP: 
sql = "SELECT * FROM [" & Ws.Name & "$B4:K" & lR & "]"
Thành:
PHP: 
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:
PHP: 
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.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

C
  • Question
Tổng hợp và nhóm nhân viên
    • Thích
Trả lời
12
Đọc
375
SA_DQ
SA_DQ
LuuAnh980
Cập nhật hợp đồng của mã vật tư theo ngày.
Trả lời
8
Đọc
59
LuuAnh980
LuuAnh980
Maika8008
  • Question
Add-In .xlam trộn dữ liệu Excel vào Word
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
25
Đọc
1K
ngochienbmt
N
phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
2
Trả lời
22
Đọc
245
phanmoi688
phanmoi688
T
Xin chỉ giáo thêm về hàm Filter
Trả lời
2
Đọc
73
thaibaovt
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom