Giúp em: Code xuất dữ liệu trong excel!!!

Liên hệ QC
T

thanhquangauh

Thành viên chính thức
Tham gia
22/9/13
Bài viết
60
Được thích
2
CHÀO CÁC ANH CHỊ GPE!! CÁC ANH CHỊ GIÚP EM CODE XUẤT DỮ LIỆU TRONG EXCEL.....
VÍ DỤ: E CÓ 2 FILE: FILE "DU LIEU" VÀ FILE "XUAT DU LIEU" ĐỂ CÙNG THƯ MỤC,
TRONG FILE "DU LIEU" CÓ SHEETS "DULIEU", KHI ẤN NÚT "XUAT DU LIEU" THÌ FILE "XUAT DU LIEU" MỞ LÊN VÀ CHUYỂN DỮ LIỆU TỪ FILE "DU LIEU" SANG FILE "XUAT DU LIEU"...
XIN CẢM ƠN RẤT NHIỀU....
http://www.mediafire.com/download/hku12mk1t2v2au8/LOC VI TRI.rar
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Các anh chị trong GPE giúp dùm e,...trong câu hỏi có vướng mắc gì em bổ xung thêm...em cám ơn nhiều...(không biết tại sao khi đính kèm tập tin lại báo lỗi nên em kèm trên www.mediafire.com xin anh chị thông cảm)..
 
Upvote 0
Bạn thử đoạn code này nếu không được ta dùng cách khác mình có chỉnh lại cấu trúc file mà giữ nguyên cũng được vì cho dễ nhìn

[GPECODE=vb]
Sub ChuyenDL()

Dim cnn As Object
Set cnn = CreateObject("ADODB.Connection")

With cnn

.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & _
"\XUAT DU LIEU.xls;Extended Properties=""Excel 8.0;HDR=Yes;"""
.Open
.Execute "INSERT INTO [LUCN$] SELECT Story,Frame,Station,OutputCase,N FROM [Excel 8.0;Database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Dulieu$A1:I1000]"
.Execute "INSERT INTO [LUCV$] SELECT Story,Frame,Station,OutputCase,V2,V3 FROM [Excel 8.0;Database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Dulieu$A1:I1000]"
.Execute "INSERT INTO [LUCM$] SELECT Story,Frame,Station,OutputCase,M2,M3 FROM [Excel 8.0;Database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Dulieu$A1:I1000]"
End With

cnn.Close: Set cnn = Nothing

End Sub


[/GPECODE]
 

File đính kèm

  • LOC VI TRI.zip
    32.1 KB · Đọc: 41
Upvote 0
nmhung49 đã viết:
Bạn thử đoạn code này nếu không được ta dùng cách khác mình có chỉnh lại cấu trúc file mà giữ nguyên cũng được vì cho dễ nhìn

[GPECODE=vb]
Sub ChuyenDL()

Dim cnn As Object
Set cnn = CreateObject("ADODB.Connection")

With cnn

.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & _
"\XUAT DU LIEU.xls;Extended Properties=""Excel 8.0;HDR=Yes;"""
.Open
.Execute "INSERT INTO [LUCN$] SELECT Story,Frame,Station,OutputCase,N FROM [Excel 8.0;Database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Dulieu$A1:I1000]"
.Execute "INSERT INTO [LUCV$] SELECT Story,Frame,Station,OutputCase,V2,V3 FROM [Excel 8.0;Database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Dulieu$A1:I1000]"
.Execute "INSERT INTO [LUCM$] SELECT Story,Frame,Station,OutputCase,M2,M3 FROM [Excel 8.0;Database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Dulieu$A1:I1000]"
End With

cnn.Close: Set cnn = Nothing

End Sub


[/GPECODE]
Nhấp chuột vào đây để mở rộng...
cảm ơn anh rất nhiều,..nhưng có thể khi bấm vào nút "Run" của anh thì file "XUAT DU LIEU" mở lên, rồi mới copy dữ liệu ở file "DU LIEU" sang file "XUAT DU LIEU"...
(ở bài của anh nmhung49 khi em xóa dữ liệu ở file "XUAT DU LIEU" đi hết thì khi bấm nút "run" thì nó ko copy dữ liệu ở file "DULIEU" sang file "XUAT DU LIEU", xin anh chỉnh lại giúp em)
chân thành cảm ơn rất nhiều...
 
Upvote 0
thanhquangauh đã viết:
CHÀO CÁC ANH CHỊ GPE!! CÁC ANH CHỊ GIÚP EM CODE XUẤT DỮ LIỆU TRONG EXCEL.....
VÍ DỤ: E CÓ 2 FILE: FILE "DU LIEU" VÀ FILE "XUAT DU LIEU" ĐỂ CÙNG THƯ MỤC,
TRONG FILE "DU LIEU" CÓ SHEETS "DULIEU", KHI ẤN NÚT "XUAT DU LIEU" THÌ FILE "XUAT DU LIEU" MỞ LÊN VÀ CHUYỂN DỮ LIỆU TỪ FILE "DU LIEU" SANG FILE "XUAT DU LIEU"...
XIN CẢM ƠN RẤT NHIỀU....
http://www.mediafire.com/download/hku12mk1t2v2au8/LOC VI TRI.rar
Nhấp chuột vào đây để mở rộng...

Code bài số 3 chạy đúng rồi mà.
 
Lần chỉnh sửa cuối:
Upvote 0
quanghai1969 đã viết:
Code bài số 3 chạy đúng rồi mà.
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh, Bài #3 chạy đúng rồi nhưng sao em bấm "Run" nó không ra kết quả....
file đính kèm 1:http://www.mediafire.com/download/ymbs6887sbq7olq/xuat%20du%20lieu.rar
anh xem rồi chỉnh lại giúp em...
Mak anh giúp em viết code sao cho khi chuyển dữ liệu thì file "XUAT DU LIEU" hiện lên luôn...
nếu như file "DU LIEU" em có thêm những số liệu phụ thì em kho6nh dựa vào code của anh để hiệu chỉnh lại được anh xem file rồi viết code lại giúp em...
file đính kèm 2:http://www.mediafire.com/download/n4vosw2pb2mj78z/chuyen%20du%20lieu%201.rar
em chân thành cảm ơn rất nhiều.....
 
Upvote 0
Ok bạn thử lại đoạn code này xem file đính kèm nếu không được thì dùng cách khác lấy dữ liệu luôn
[GPECODE=vb]
Sub ChuyenDL()

Dim cnn As Object
Dim WbOpen As Workbook, Sh As Worksheet
Set cnn = CreateObject("ADODB.Connection")
Set WbOpen = Application.Workbooks.Open(ThisWorkbook.Path & "\XUAT DU LIEU.xls")
With WbOpen
For Each Sh In .Worksheets
Sh.Range("A15:F10000").Clear
Next


End With
ThisWorkbook.Activate
With cnn

.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & _
"\XUAT DU LIEU.xls;Extended Properties=""Excel 8.0;HDR=Yes;"""
.Open
.Execute "INSERT INTO [LUCN$A13:E1000]([Story],[Frame],[Station],[OutputCase],[N]) SELECT [Story],[Frame],[Station],[OutputCase],[N] FROM [Excel 8.0;Database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Dulieu$A13:I1000]"
.Execute "INSERT INTO [LUCV$A13:F1000]([Story],[Frame],[Station],[OutputCase],[V2],[V3]) SELECT [Story],[Frame],[Station],[OutputCase],[V2],[V3] FROM [Excel 8.0;Database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Dulieu$A13:I1000]"
.Execute "INSERT INTO [LUCM$A13:F1000]([Story],[Frame],[Station],[OutputCase],[M2],[M3]) SELECT [Story],[Frame],[Station],[OutputCase],[M2],[M3] FROM [Excel 8.0;Database=" & _
ThisWorkbook.FullName & ";HDR=Yes].[Dulieu$A13:I1000]"

End With

cnn.Close: Set cnn = Nothing

End Sub


[/GPECODE]

Các vùng bạn có thể thay đổi tuỳ ý nhưng tên cột thì không nên thay đổi
 

File đính kèm

  • chuyen du lieu 1.rar
    28.9 KB · Đọc: 28
Upvote 0
thanhquangauh đã viết:
Cảm ơn anh, Bài #3 chạy đúng rồi nhưng sao em bấm "Run" nó không ra kết quả....
file đính kèm 1:http://www.mediafire.com/download/ymbs6887sbq7olq/xuat%20du%20lieu.rar
anh xem rồi chỉnh lại giúp em...
Mak anh giúp em viết code sao cho khi chuyển dữ liệu thì file "XUAT DU LIEU" hiện lên luôn...
nếu như file "DU LIEU" em có thêm những số liệu phụ thì em kho6nh dựa vào code của anh để hiệu chỉnh lại được anh xem file rồi viết code lại giúp em...
file đính kèm 2:http://www.mediafire.com/download/n4vosw2pb2mj78z/chuyen%20du%20lieu%201.rar
em chân thành cảm ơn rất nhiều.....
Nhấp chuột vào đây để mở rộng...
Mình chưa biết ADO, viết VBA thử xem sao:
PHP: 
Public Sub GPE()
Application.ScreenUpdating = False
Dim sArr(), dArr1(), dArr2(), dArr3(), I As Long, J As Long, K As Long, DK As Long
sArr = Range([A15], [A65536].End(xlUp)).Resize(, 9).Value
ReDim dArr1(1 To UBound(sArr, 1), 1 To 5)
ReDim dArr2(1 To UBound(sArr, 1), 1 To 6)
ReDim dArr3(1 To UBound(sArr, 1), 1 To 6)
'----------------------------------------- Gan du lieu vao 3 mang
For I = 1 To UBound(sArr, 1)
    For J = 1 To 4
        dArr1(I, J) = sArr(I, J)
        dArr2(I, J) = sArr(I, J)
        dArr3(I, J) = sArr(I, J)
    Next J
    dArr1(I, 5) = sArr(I, 5)
    dArr2(I, 5) = sArr(I, 6): dArr2(I, 6) = sArr(I, 7)
    dArr3(I, 5) = sArr(I, 8): dArr3(I, 6) = sArr(I, 9)
Next I
I = I - 1
Workbooks.Open Filename:=ThisWorkbook.Path & "\Xuat du lieu.xls"
'------------------------------------------Gan 3 mang vao 3 sheet
With Sheets("LUCN")
    .[A15:E10000].ClearContents
    .[A15].Resize(I, 5).Value = dArr1
End With
With Sheets("LUCV")
    .[A15:F10000].ClearContents
    .[A15].Resize(I, 6).Value = dArr2
End With
With Sheets("LUCM")
    .[A15:E10000].ClearContents
    .[A15].Resize(I, 6).Value = dArr3
End With
Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Có 1 chiêu tà đạo đây, vì dữ liệu kỳ quá. Chiêu này bảo đảm không đụng hàng
Code của anh Bate cũng thuộc nhóm tà đạo nhưng chắc không thể tà đạo hơn code này rồi.
PHP: 
Sub ChuyenDuLieu()
Dim FileName As String, WB As Workbook, DL As Worksheet
Dim SheetName(), I As Long, J As Long, K As Byte, N As Byte, X As Byte
Dim sarr(), Darr()
SheetName = Array("LUCN", "LUCV", "LUCM")
FileName = "XUAT DU LIEU.xls"
Set DL = Workbooks("DULIEU").Sheets("DULIEU")
sarr = DL.Range(DL.[A15], DL.[A65536].End(3)).Resize(, 4).Value
For Each WB In Workbooks
   If WB.Name = FileName Then K = 1
Next
If K = 0 Then Workbooks.Open (ThisWorkbook.Path & "\" & FileName)
With Workbooks(FileName)
   N = 3
   For I = 0 To UBound(SheetName)
      X = IIf(I = 0, 3, 4)
      Darr = DL.Range(DL.[A15], DL.[A65536].End(3)).Offset(, N).Resize(, 2).Value
      With .Sheets(SheetName(I)).[A65536].End(3)
         .Offset(1).Resize(UBound(sarr), 4) = sarr
         .Offset(1, X).Resize(UBound(sarr), 2) = Darr
      End With
      N = N + 2
   Next
End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Thêm chiêu này còn dã man hơn nữa nè. Mượn mấy cái biến của anh Bate xài luôn
Khỏi xài vòng lặp nào hết ráo
PHP: 
Public Sub GPE()
Dim sArr(), dArr1(), dArr2(), dArr3()
Dim I As Byte, DL As Worksheet

Set DL = ThisWorkbook.Sheets("DULIEU")
With DL.Range(DL.[A15], DL.[A65536].End(xlUp))
   sArr = .Resize(, 4).Value
   dArr1 = .Offset(, 4).Value
   dArr2 = .Offset(, 5).Resize(, 2).Value
   dArr3 = .Offset(, 7).Resize(, 2).Value
End With

Workbooks.Open FileName:=ThisWorkbook.Path & "\Xuat du lieu.xls"

      Sheets("LUCN").[A15:E10000].ClearContents
      Sheets("LUCN").[A15].Resize(UBound(sArr), 4).Value = sArr
      Sheets("LUCN").[A15].Offset(, 4).Resize(UBound(sArr)).Value = dArr1
      Sheets("LUCV").[A15:E10000].ClearContents
      Sheets("LUCV").[A15].Resize(UBound(sArr), 4).Value = sArr
      Sheets("LUCV").[A15].Offset(, 4).Resize(UBound(sArr), 2).Value = dArr2
      Sheets("LUCM").[A15:E10000].ClearContents
      Sheets("LUCM").[A15].Resize(UBound(sArr), 4).Value = sArr
      Sheets("LUCM").[A15].Offset(, 4).Resize(UBound(sArr), 2).Value = dArr3
End Sub
 
Upvote 0
Rất cảm ơn các anh đã góp bài (rất nhiều kết quả hay)...E tham khảo bài của các anh và chỉnh lại được theo ý của mình (muốn chuyển thế nào cũng được), nhưng sau khi file "xuat du lieu" đã hiện lên rồi thì bấm vào nút "xuat du lieu" thì cho dù file "xuat du lieu" đã mở rồi thì nó vẫn chuyển dữ liệu qua file "xuat du lieu"....Xin các anh hiệu chỉnh lại dùm em...Chân thành cảm ơn...
Sub xuatDL()
Application.ScreenUpdating = False
Workbooks.Open FileName:=ThisWorkbook.Path & "\Xuat du lieu.xls"
'------------------------------------------
Workbooks("XUAT DU LIEU.xls").Sheets("LUCN").[A13:E65000].Value = Workbooks("DULIEU.xls").Sheets("DULIEU").[A13:E65000].Value
'------------------------------------------
Workbooks("XUAT DU LIEU.xls").Sheets("LUCV").[A13:D65000].Value = Workbooks("DULIEU.xls").Sheets("DULIEU").[A13:D65000].Value
Workbooks("XUAT DU LIEU.xls").Sheets("LUCV").[E13:F65000].Value = Workbooks("DULIEU.xls").Sheets("DULIEU").[F13:G65000].Value
'------------------------------------------
Workbooks("XUAT DU LIEU.xls").Sheets("LUCM").[A13:D65000].Value = Workbooks("DULIEU.xls").Sheets("DULIEU").[A13:D65000].Value
Workbooks("XUAT DU LIEU.xls").Sheets("LUCM").[E13:F65000].Value = Workbooks("DULIEU.xls").Sheets("DULIEU").[H13:I65000].Value
Application.ScreenUpdating = True
End Sub
file đính kèm 2:http://www.mediafire.com/download/n4...lieu%25201.rar
 
Upvote 0
Cho em bổ sung thêm 1 ý nữa là: Nếu như 2 file không cùng ở 1 thư mục (mỗi file ở mỗi thư mục khác nhau) thì phải điều chỉnh code như thế nào?
VD: file "DULIEU" ở thư mục là "folder1"; file "XUAT DU LIEU" ở thư mục là "folder2"
E chân thành cảm ơn....
 
Lần chỉnh sửa cuối:
Upvote 0
thanhquangauh đã viết:
Cho em bổ sung thêm 1 ý nữa là: Nếu như 2 file không cùng ở 1 thư mục (mỗi file ở mỗi thư mục khác nhau) thì phải điều chỉnh code như thế nào?
VD: file "DULIEU" ở thư mục là "folder1"; file "XUAT DU LIEU" ở thư mục là "folder2"
E chân thành cảm ơn....
Nhấp chuột vào đây để mở rộng...
Chỉnh code
Workbooks.Open FileName:=ThisWorkbook.Path & "\Xuat du lieu.xls"
Nhấp chuột vào đây để mở rộng...
Thành code
PHP: 
Workbooks.Open (Application.GetOpenFilename)
nhưng sau khi file "xuat du lieu" đã hiện lên rồi thì bấm vào nút "xuat du lieu" thì cho dù file "xuat du lieu" đã mở rồi thì nó vẫn chuyển dữ liệu qua file "xuat du lieu"....Xin các anh hiệu chỉnh lại dùm em...Chân thành cảm ơn...
Nhấp chuột vào đây để mở rộng...
Tạo thêm trường hợp bẫy lỗi nữa nếu file mở lên rồi thì khỏi open đó nữa thôi cái này để anh Hải làm đi nhen
 
Lần chỉnh sửa cuối:
Upvote 0
nmhung49 đã viết:
PHP: 
Workbooks.Open (Application.GetOpenFilename)

Tạo thêm trường hợp bẫy lỗi nữa nếu file mở lên rồi thì khỏi open đó nữa thôi cái này để anh Hải làm đi nhen
Nhấp chuột vào đây để mở rộng...
->trường hợp này nhờ các anh giúp dùm em....
........................
- Vậy nếu Nếu như 2 file không cùng ở 1 thư mục (mỗi file ở mỗi thư mục khác nhau) thì mình có thể thêm cái địa chỉ của cái file "XUAT DU LIEU" (tên ổ đĩa chứa thư mục, tên thư mục,tên file) mà ko cần dùng "Workbooks.Open (Application.GetOpenFilename)" được ko! xin hiệu chỉnh dùm em...
 
Upvote 0
thanhquangauh đã viết:
->trường hợp này nhờ các anh giúp dùm em....
........................
- Vậy nếu Nếu như 2 file không cùng ở 1 thư mục (mỗi file ở mỗi thư mục khác nhau) thì mình có thể thêm cái địa chỉ của cái file "XUAT DU LIEU" (tên ổ đĩa chứa thư mục, tên thư mục,tên file) mà ko cần dùng "Workbooks.Open (Application.GetOpenFilename)" được ko! xin hiệu chỉnh dùm em...
Nhấp chuột vào đây để mở rộng...
Cú pháp để mở 1 file khi biết rõ đường dẫn
WorkBooks.Open "tên đường dẫn đầy đủ"
Ví dụ:
WorkBooks.Open "D:\LUONG\NAM2013\Thang11.xls"
 
Upvote 0
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
Giúp em viết công thức làm lịch thi đấu.
Trả lời
0
Đọc
1
caocat
C
D
Tính khoảng cách giữa 2 tọa độ?
Trả lời
4
Đọc
49
danhculao
D
pupuchcha
  • Question
Viết code để tìm xích ma, mong mọi người giúp đỡ em ạ
Trả lời
0
Đọc
14
pupuchcha
pupuchcha
K
Nhờ mọi người hỗ trợ giúp mình về tìm kiếm trong VBA. Mình sẽ gửi chút chi phí cafe cám ơn nhiều ạ
    • Cười
Trả lời
18
Đọc
291
VetMini
V
hongquan93vn
Giữ được Hide dòng khi dùng "clear" trong phần học
Trả lời
4
Đọc
97
ngocmaipretty
ngocmaipretty
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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