Em có file gốc là Reportdata. Ở sheet1 của file test em đã run được sub chuyển đổi khi em copy dữ liệu vào đó. Bây giờ em muốn run ở sheet 2 với dữ liệu ở sheet 1 thì em phải sửa code thế nào. Hoặc nếu có thể nhờ các anh giúp em lấy dữ liệu từ file data và chuyển đổi vào sheet 2 được không ạ. Và cả với hai trường hợp trên em muốn có thể lúc chuyển sang nó sẽ cho mình chọn ô để bắt đầu paste dữ liệu có được không???
nhờ giúp đỡ chuyển số liệu từ file khác sang sheet hiện thời ở vị trí tùy chọn (1 người xem)
- Thread starter pinklove
- Ngày gửi
Người dùng đang xem chủ đề này
Bạn giúp mình cái vụ lấy dữ liệu từ file gốc và sau đó khi dán kết quả thì nó sẽ hỏi mình dán vào đâu được ko???
Upvote
0
Mình giờ mới thử cách của bạn nhưng ý muốn của mình lại khác. Đó là mình muốn button đặt ở sheet2, thực hiện lệnh ở sheet2 chứ không phải là để button ở sheet1
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Bạn hãy sửa code với dữ liệu nguồn lấy từ sheet1, rồi gán kết quả như #2 sau đó vẽ button ở sheet2 là sẽ được thôi.
Upvote
0
mình sửa ko đc mới lên đây nhờ giúp chứ bạn.
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Không biết code này ai đã viết cho bạn, mạo muội xin phép sửa theo yêu cầu của bạn:
Mã:
Public Sub Exporting()
Dim sArr(), dArr(), i
With Sheet1
sArr = .Range(.[E14], .[E14].End(xlDown)).Resize(, 6).Value
End with
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
For i = 1 To UBound(sArr, 1)
dArr(i, 1) = Mid(sArr(i, 1), InStr(sArr(i, 1), ":") + 1, Len(sArr(i, 1)) - InStr(sArr(i, 1), ":") - 5)
dArr(i, 2) = TimeSerial(Hour(sArr(i, 5)), Minute(sArr(i, 5)), Second(sArr(i, 5)))
dArr(i, 3) = DateSerial(Year(sArr(i, 5)), Month(sArr(i, 5)), Day(sArr(i, 5)))
If sArr(i, 3) <> Empty Then
dArr(i, 4) = TimeSerial(Hour(sArr(i, 6)), Minute(sArr(i, 6)), Second(sArr(i, 6)))
dArr(i, 5) = DateSerial(Year(sArr(i, 6)), Month(sArr(i, 6)), Day(sArr(i, 6)))
End If
Next i
Sheet2.[A5:E10000].ClearContents
Sheet2.[A5].Resize(i - 1, 5) = dArr
End Sub
Upvote
0
doveandrose
hello
- Tham gia
- 3/7/09
- Bài viết
- 2,372
- Được thích
- 2,263
ủa sao các bạn ở trên không trả lời câu này ta ? hi hi
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Kiểu như Application.InputBox. Nghĩ là vậy nhưng hên xui.
Upvote
0
Mình cũng sửa với with ... y như vậy, nhưng mình đặt End With cuối cùng ngay trước End sub nên code không chạy. Cảm ơn bạn.
Bạn cứ thử cho mình cái. Biết đâu lại hên.
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Vậy thì mình cứ hên xui nha:Bạn cứ thử cho mình cái. Biết đâu lại hên.
Mã:
Public Sub Exporting()
Dim sArr(), dArr(), i, Rng
With Sheet1
sArr = .Range(.[E14], .[E14].End(xlDown)).Resize(, 6).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
For i = 1 To UBound(sArr, 1)
dArr(i, 1) = Mid(sArr(i, 1), InStr(sArr(i, 1), ":") + 1, Len(sArr(i, 1)) - InStr(sArr(i, 1), ":") - 5)
dArr(i, 2) = TimeSerial(Hour(sArr(i, 5)), Minute(sArr(i, 5)), Second(sArr(i, 5)))
dArr(i, 3) = DateSerial(Year(sArr(i, 5)), Month(sArr(i, 5)), Day(sArr(i, 5)))
If sArr(i, 3) <> Empty Then
dArr(i, 4) = TimeSerial(Hour(sArr(i, 6)), Minute(sArr(i, 6)), Second(sArr(i, 6)))
dArr(i, 5) = DateSerial(Year(sArr(i, 6)), Month(sArr(i, 6)), Day(sArr(i, 6)))
End If
Next i
On Error GoTo GPE
Set Rng = Application.InputBox("Chon noi de dat", Type:=8)
Rng.Resize(i - 1, 5) = dArr
GPE:
End Sub
Upvote
0
Hên được một nửa rồi bạn ơi. Đã chọn được vị trí dán kết quả, nhưng nguồn vẫn lấy từ sheet1. Mình còn mong muốn là nguồn được lấy từ sheet1 của file khác nữa. Nó có dạng như file reportdata mình gửi kèm ở bài đầu đó. Nếu có thể làm được lúc đầu nó sẽ hỏi file nguồn rồi sau đó hỏi vị trí dán như code trên thì tuyệt. Đỡ được một bước copy từ file export vào sheet1 của file chương trình.
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Các file khác được bố trí như thế nào, có cấu trúc như file #1 hông. Với lại yêu cầu mới này không phù hợp với tiêu đề của topic nữa rồi thì phải. Bạn có thể tạo topic mới rồi đưa vài file nguồn lên để mọi người cùng giải quyết.
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Có cái câu này nè:
Bạn đừng nói có thể lưu cùng tên nhiều loại .xls* nha. Mới lại hình như cái khoản mới này hợp với doveandrose hơn. Hỏi xoáy quá.....biết trả lời sao. HuHu
Upvote
0
doveandrose
hello
- Tham gia
- 3/7/09
- Bài viết
- 2,372
- Được thích
- 2,263
Có cái câu này nè:
Bạn đừng nói có thể lưu cùng tên nhiều loại .xls* nha. Mới lại hình như cái khoản mới này hợp với doveandrose hơn. Hỏi xoáy quá.....biết trả lời sao. HuHu
bạn tham gia code rồi thì chịu khó chơi tới bến đi mà .... chứ giờ bắt tôi làm thì tôi lại phải đọc hết lại từ #1 xem có những chuyện gì từ đầu đến giờ mất thời gian lắm
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Code trên đâu phải của tui, nhiều chuyện nhào vô sửa giúp ấy chứ. Sửa quá lại tự thấy hỏng hết cái code đẹp ban đầu, với lại ai mà biết được 1 "nùi" file nguồn của người ta nó như thế nào cơ chứ.
Upvote
0
Hì, các xếp thôi cãi nhau để dành thời gian giúp em đi ạ. File nguồn em Export ra đúng y chang file Reportdata đó ạ. Còn bố trí file thì em nghĩ không quan trọng vì em có thể chọn vị trí dán kết quả rồi. Ý em muốn đúng là nó sẽ hiện ra form cho mình chọn đường dẫn đến file nguồn (như open file ấy) chứ ko phụ thuộc vào filename ạ.
Lần chỉnh sửa cuối:
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Chỉ là đang nói chuyện bình thường thôi, có cãi nhau đâu, hehe.Nói chung là làm được. Nhưng đến giờ ăn nhậu rồi, có gì tối kịp tỉnh thì làm rồi gửi bài cho bạn tham khảo.
Upvote
0
Cố gắng tỉnh nhá. Tối giúp tớ xong tớ mời bạn vài quai nữa khi đó xỉn cũng được.
Upvote
0
giangleloi
Thành viên gắn bó
- Tham gia
- 25/3/13
- Bài viết
- 1,883
- Được thích
- 1,441
Quên mất không hỏi bạn cái nơi đặt kết quả là đặt hết vô 1 File hay đặt riêng vô từng file khi mở ra. Bạn bỏ code vô 1 file trắng rồi copy vài file nguồn ra trước rồi hãy chạy code (Lỡ hư file gốc là hông chịu trách nhiệm đâu nha).
Mã:
Public Sub Exporting()
Dim sArr(), dArr(), i, Rng, wk, wks, x, str
On Error GoTo GPE
wks = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)
For x = LBound(wks) To UBound(wks)
str = wks(x)
Set wk = Workbooks.Open(str)
With ActiveWorkbook.Sheets("Sheet1")
sArr = .Range(.[E14], .[E14].End(xlDown)).Resize(, 6).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
For i = 1 To UBound(sArr, 1)
dArr(i, 1) = Mid(sArr(i, 1), InStr(sArr(i, 1), ":") + 1, Len(sArr(i, 1)) - InStr(sArr(i, 1), ":") - 5)
dArr(i, 2) = TimeSerial(Hour(sArr(i, 5)), Minute(sArr(i, 5)), Second(sArr(i, 5)))
dArr(i, 3) = DateSerial(Year(sArr(i, 5)), Month(sArr(i, 5)), Day(sArr(i, 5)))
If sArr(i, 3) <> Empty Then
dArr(i, 4) = TimeSerial(Hour(sArr(i, 6)), Minute(sArr(i, 6)), Second(sArr(i, 6)))
dArr(i, 5) = DateSerial(Year(sArr(i, 6)), Month(sArr(i, 6)), Day(sArr(i, 6)))
End If
Next i
Set Rng = Application.InputBox("Chon noi de dat", Type:=8)
Rng.Resize(i - 1, 5) = dArr
wk.Close True
Next x
GPE:
End Sub
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,972
Thông thường nếu dùng GetOpenFilename thì người ta sẽ bẫy lỗi thế này:
- Nếu dùng đối số MultiSelect:=False thì người ta sẽ xét kết quả xem nó có là String hay không (If TypeName(...) = "String" then)
- Nếu dùng đối số MultiSelect:=True thì người ta sẽ xét kết quả xem nó có là Array hay không (If TypeName(...) = "Variant" then hoặc If IsArray(...) then)
- Việc dùng On Error... chỉ nên xem là giải pháp dự phòng khi mà ta không chắc các lỗi có thể xảy ra
Tóm lại: Bẫy lỗi cho code là việc tốt nhưng bẫy lỗi theo cách CHỦ ĐỘNG thì càng tốt hơn
Upvote
0
Mình đã thử code và vấp lỗi như sau. Khi mình chọn file nguồn xong nó open file nguồn lên thì mình ko làm sao chọn sang file đích để chọn vị trí dán được. Phải tắt hộp input thì mới chuyển được nhưng thế thì lại ko chọn được chỗ dán ở file đích mà chỉ có thể dán luôn lên trên file nguồn. bạn xem lại hộ mình nhé. Kết quả chỉ đặt ại sheet mình chọn vị trí dán thôi.
Lần chỉnh sửa cuối:
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,972
Bác Giang chắc đi.. giang hồ rồi. Giờ tôi thay mặt bác Giang sửa code bài 22 và chỉ sửa cho chạy được thôi nha:
Mã:
Public Sub Exporting()
Dim sArr(), dArr(), vFile
Dim wkb As Workbook, wks As Worksheet, rng As Range
Dim sFile As String
Dim i As Long
vFile = Application.GetOpenFilename("Excel Files, *.xls*")
If TypeName(vFile) = "String" Then
sFile = CStr(vFile)
Application.ScreenUpdating = False
Set wkb = Workbooks.Open(sFile)
Set wks = wkb.Worksheets("Sheet1")
sArr = wks.Range("J14", wks.Range("E60000").End(xlUp)).Value
wkb.Close False
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
For i = 1 To UBound(sArr, 1)
dArr(i, 1) = Mid(sArr(i, 1), InStr(sArr(i, 1), ":") + 1, Len(sArr(i, 1)) - InStr(sArr(i, 1), ":") - 5)
[COLOR=#ff0000]dArr(i, 2) = TimeSerial(Hour(sArr(i, 5)), Minute(sArr(i, 5)), Second(sArr(i, 5)))
dArr(i, 3) = DateSerial(Year(sArr(i, 5)), Month(sArr(i, 5)), Day(sArr(i, 5)))[/COLOR]
If sArr(i, 3) <> Empty Then
[COLOR=#ff0000]dArr(i, 4) = TimeSerial(Hour(sArr(i, 6)), Minute(sArr(i, 6)), Second(sArr(i, 6)))
dArr(i, 5) = DateSerial(Year(sArr(i, 6)), Month(sArr(i, 6)), Day(sArr(i, 6)))[/COLOR]
End If
Next i
Application.ScreenUpdating = True
On Error Resume Next
Set rng = Application.InputBox("Chon noi de dat", Type:=8)
On Error GoTo 0
If Not rng Is Nothing Then
With rng.Resize(i - 1, 5)
.Value = dArr
.EntireColumn.AutoFit
End With
End If
End If
End Sub
Lần chỉnh sửa cuối:
Upvote
0
Em cảm ơn anh. CHạy tốt rồi anh ạ. Code này lúc đầu của anh Ba Tê giúp em. Mấy cái dòng màu đỏ đó anh có nói đến trong bài đó rồi. Lúc đó em có hỏi anh cách khắc phục nhưng a chưa trả lời. Anh có thể giúp em làm sao cho nó luôn định dạng ở kiểu dd/mm/yyyy được không ạ.
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,972
Cái định dạng dd/mm/yyyy ấy không quan trọng, bởi bạn có thể Custom Format bằng tay cũng ra
Vấn đề là:
- Nếu như ta viết dArr(i, 3) = DateSerial(Year(sArr(i, 5)), Month(sArr(i, 5)), Day(sArr(i, 5))) thì ta đã mặc định xem thằng sArr(i, 5) ấy là Date rồi nhưng thực chất đâu phải vậy (vì dữ liệu nguồn đang là text)
- Nếu muốn dArr(i, 3) là Date thật sự thì phải dùng hàm xử lý chuỗi đối với sArr(i, 5)
Tôi làm luôn cho bạn 2 món:
- Chuyển chuỗi thành Date "chính chủ"
- Format dd/mm/yyyy và hh:mm:ss luôn
Mã:
Public Sub Exporting()
Dim sArr(), dArr(), vFile
Dim wkb As Workbook, wks As Worksheet, rng As Range
Dim sFile As String, tmp As String
Dim i As Long
vFile = Application.GetOpenFilename("Excel Files, *.xls*")
If TypeName(vFile) = "String" Then
sFile = CStr(vFile)
Application.ScreenUpdating = False
Set wkb = Workbooks.Open(sFile)
Set wks = wkb.Worksheets("Sheet1")
sArr = wks.Range("J14", wks.Range("E60000").End(xlUp)).Value
wkb.Close False
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
For i = 1 To UBound(sArr, 1)
tmp = Mid(sArr(i, 1), InStr(sArr(i, 1), ":") + 1)
dArr(i, 1) = Left(tmp, Len(tmp) - 5)
[COLOR=#ff0000]dArr(i, 2) = TimeValue(Right(sArr(i, 5), 8))[/COLOR]
[COLOR=#ff0000]dArr(i, 3) = DateSerial(Mid(sArr(i, 5), 7, 4), Mid(sArr(i, 5), 4, 2), Left(sArr(i, 5), 2))[/COLOR]
If sArr(i, 3) <> Empty Then
[COLOR=#ff0000]dArr(i, 4) = TimeValue(Right(sArr(i, 6), 8))
dArr(i, 5) = DateSerial(Mid(sArr(i, 6), 7, 4), Mid(sArr(i, 6), 4, 2), Left(sArr(i, 6), 2))[/COLOR]
End If
Next i
Application.ScreenUpdating = True
On Error Resume Next
Set rng = Application.InputBox("Chon noi de dat", Type:=8)
On Error GoTo 0
If Not rng Is Nothing Then
With rng.Resize(i - 1, 5)
.Value = dArr
.EntireColumn.AutoFit
[COLOR=#0000cd]Union(.Offset(, 1), .Offset(, 3)).NumberFormat = "hh:mm:ss"
Union(.Offset(, 2), .Offset(, 4)).NumberFormat = "dd/mm/yyyy"[/COLOR]
End With
End If
End If
Exit Sub
End Sub- Dòng màu xanh là Format theo ý bạn
Upvote
0
Anh xem lại giúp em có cột bị lỗi như trong hình kèm theo đây ạ.
File đính kèm
Upvote
0
- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,972
Cái tội viết mà tự tin quá nên không chịu test lại:
Mã:
Public Sub Exporting()
Dim sArr(), dArr(), vFile
Dim wkb As Workbook, wks As Worksheet, rng As Range
Dim sFile As String, tmp As String
Dim i As Long
vFile = Application.GetOpenFilename("Excel Files, *.xls*")
If TypeName(vFile) = "String" Then
sFile = CStr(vFile)
Application.ScreenUpdating = False
Set wkb = Workbooks.Open(sFile)
Set wks = wkb.Worksheets("Sheet1")
sArr = wks.Range("J14", wks.Range("E60000").End(xlUp)).Value
wkb.Close False
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
For i = 1 To UBound(sArr, 1)
tmp = Mid(sArr(i, 1), InStr(sArr(i, 1), ":") + 1)
dArr(i, 1) = Left(tmp, Len(tmp) - 5)
dArr(i, 2) = TimeValue(Right(sArr(i, 5), 8))
dArr(i, 3) = DateSerial(Mid(sArr(i, 5), 7, 4), Mid(sArr(i, 5), 4, 2), Left(sArr(i, 5), 2))
If sArr(i, 3) <> Empty Then
dArr(i, 4) = TimeValue(Right(sArr(i, 6), 8))
dArr(i, 5) = DateSerial(Mid(sArr(i, 6), 7, 4), Mid(sArr(i, 6), 4, 2), Left(sArr(i, 6), 2))
End If
Next i
Application.ScreenUpdating = True
On Error Resume Next
Set rng = Application.InputBox("Chon noi de dat", Type:=8)
On Error GoTo 0
If Not rng Is Nothing Then
With rng.Resize(i - 1, 5)
.Value = dArr
.EntireColumn.AutoFit
Union(.Offset(, 1)[COLOR=#ff0000].Resize(, 1)[/COLOR], .Offset(, 3)[COLOR=#ff0000].Resize(, 1)[/COLOR]).NumberFormat = "hh:mm:ss"
Union(.Offset(, 2)[COLOR=#ff0000].Resize(, 1)[/COLOR], .Offset(, 4).[COLOR=#ff0000]Resize(, 1)[/COLOR]).NumberFormat = "dd/mm/yyyy"
End With
End If
End If
Exit Sub
End Sub
Upvote
0
Em cảm ơn anh. Ổn rồi ạ. Cũng liên quan đến code này nhưng ở bài cũ, Em có hỏi thêm một trường hợp. ANh giúp cho em luôn được không ạ. Em không hỏi ở đây vì sẽ sai chủ đề topic. Em hỏi tiếp ở bài cũ tại đây ạ. Còn nếu cần phải mở topic mới hỏi về tính tổng time thì anh bảo em để em mở ạ.
Upvote
0
Bài viết mới nhất
- Question
- Question
- Question
- Question
- Đã khóa
- Question
In file excel có cột bị gộp
(1 người xem)