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 (2 người xem)
- Thread starter pinklove
- Ngày gửi
Người dùng đang xem chủ đề này
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,958
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,958
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,958
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,958
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