Chuyển dữ liệu ngày tháng xuất từ phần mềm không đúng định dạng ngày tháng Excel (2 người xem)

[HieuCD]

Người bạn nhờ viết Function chuyển dữ liệu ngày tháng xuất từ phần mềm kế toán về dạng phù hợp với bảng tính Excel, yêu cầu khá phức tạp và thiết thực với nhiều người nên mình gởi lên cho các bạn có nhu cầu tham khảo
Thuật toán dựa trên sự khác biệt về chênh lệch của từng thành phần: ngày, tháng và năm
Function nên áp dụng cho dữ liệu gốc xuất từ phần mềm chưa qua chế biến
Code chưa test hết các trường hợp nên có thể còn nhiều vấn đề cần phải hoàn thiện, nhờ các bạn góp ý thêm

 

[LienDong]

Cảm ơn bạn cái này tôi đang tìm, nhưng bạn có thể cải cách nó cho dễ sử dụng không?
Ví dụ tôi đang chọn khối ô A2:A10 thì code chỉ chạy trên khối ô này & nó trả kết quả cũng tại khối ô này
Cảm ơn các bạn nhiều.

 

[HieuCD]

Cảm ơn bạn cái này tôi đang tìm, nhưng bạn có thể cải cách nó cho dễ sử dụng không?
Ví dụ tôi đang chọn khối ô A2:A10 thì code chỉ chạy trên khối ô này & nó trả kết quả cũng tại khối ô này
Cảm ơn các bạn nhiều.

Bạn tùy biến Sub main để xử lý yêu cầu, ví dụ

Sub Main()
  Dim sArr(), Res As Variant
  sArr = Range("A2:A10").Value
  Res = ChuyeNgayThang(sArr)
  Range("A2:A10") = Res
End Sub

Thực ra chỉ cần Biến sArr, mình để thêm Biến Res cho bạn dể hình dung

 

[LienDong]

Bạn tùy biến Sub main để xử lý yêu cầu, ví dụ

Sub Main()
  Dim sArr(), Res As Variant
  sArr = Range("A2:A10").Value
  Res = ChuyeNgayThang(sArr)
  Range("A2:A10") = Res
End Sub

Thực ra chỉ cần Biến sArr, mình để thêm Biến Res cho bạn dể hình dung

Tôi không biết chỉnh những code này, Khối ô chọn là bất kỳ , nên mỗi lần đổi khối ô thì phải đổi code
Các bạn giúp, khi chọn 1 khối ô bất kỳ thì sẽ ra kết quả ở khối ô đó luôn!

 

[HieuCD]

Tôi không biết chỉnh những code này, Khối ô chọn là bất kỳ , nên mỗi lần đổi khối ô thì phải đổi code
Các bạn giúp, khi chọn 1 khối ô bất kỳ thì sẽ ra kết quả ở khối ô đó luôn!

Dùng code VBA là "hạ thủ bất hoàn" chọn vùng nhầm là tiêu, để mình tinh chỉnh lại code trước rồi viết thủ tục chọn vùng sau

 

[FatBear]

hay quá. đúng cái đang cần luôn ạ. cảm ơn sự phụ nhiều

 

[HieuCD]

Tôi không biết chỉnh những code này, Khối ô chọn là bất kỳ , nên mỗi lần đổi khối ô thì phải đổi code
Các bạn giúp, khi chọn 1 khối ô bất kỳ thì sẽ ra kết quả ở khối ô đó luôn!

Code xét thêm vài khả năng ngày tháng không chuẩn
Xem hướng dẫn cách dùng trong File, Nên dán thử kết quả ra ngoài kiểm tra lại rồi dán thực sự vào vị trí dữ liệu

 

[huonglien1901]

Người bạn nhờ viết Function chuyển dữ liệu ngày tháng xuất từ phần mềm kế toán về dạng phù hợp với bảng tính Excel, yêu cầu khá phức tạp và thiết thực với nhiều người nên mình gởi lên cho các bạn có nhu cầu tham khảo
Thuật toán dựa trên sự khác biệt về chênh lệch của từng thành phần: ngày, tháng và năm
Function nên áp dụng cho dữ liệu gốc xuất từ phần mềm chưa qua chế biến
Code chưa test hết các trường hợp nên có thể còn nhiều vấn đề cần phải hoàn thiện, nhờ các bạn góp ý thêm

Anh Hiếu ơi!
Anh xem giúp em vấn đề này với. Định dạng ngày tháng bị lẫn lộn.(trong file em có định dạng màu để cho dễ nhận dạng)

Em cảm ơn Anh nhiều!

 

[LamNA]

Anh Hiếu ơi!
Anh xem giúp em vấn đề này với. Định dạng ngày tháng bị lẫn lộn.(trong file em có định dạng màu để cho dễ nhận dạng)

Em cảm ơn Anh nhiều!

Chị thử code này thử

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim result(), change As Range
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set change = Intersect(Target, Range("I2:I600000"))
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 1)
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                result(i, 1) = Format(result(i, 1), "DD/MM/YYYY")
            End If
        Next i
        change.Offset(0, 1).Resize(, 1).Value = result
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[huonglien1901]

Chị thử code này thử

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim result(), change As Range
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set change = Intersect(Target, Range("I2:I600000"))
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 1)
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                result(i, 1) = Format(result(i, 1), "DD/MM/YYYY")
            End If
        Next i
        change.Offset(0, 1).Resize(, 1).Value = result
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Nó vẫn vậy à, vẫn không thay đổi gì cả, ngày tháng vẫn đảo lộn à,

nhờ Anh chỉnh sửa giúp em.

Em cảm ơn Anh.

 

[LamNA]

Nó vẫn vậy à, vẫn không thay đổi gì cả, ngày tháng vẫn đảo lộn à,

nhờ Anh chỉnh sửa giúp em.

Em cảm ơn Anh.

Chị bỏ code vào sheet1 nhe, em sửa lại cột J

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim result(), change As Range
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set change = Intersect(Target, Range("J2:J600000"))
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 1)
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                result(i, 1) = Format(result(i, 1), "DD/MM/YYYY")
            End If
        Next i
        change.Offset(0, 1).Resize(, 1).Value = result
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[huonglien1901]

Chị bỏ code vào sheet1 nhe, em sửa lại cột J

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim result(), change As Range
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set change = Intersect(Target, Range("J2:J600000"))
    If Not change Is Nothing Then
        result = change.Resize(change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 1)
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                result(i, 1) = Format(result(i, 1), "DD/MM/YYYY")
            End If
        Next i
        change.Offset(0, 1).Resize(, 1).Value = result
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Bỏ vào Sheet1 vẫn vậy à, Anh xem lại giúp em.

 

[LamNA]

Bỏ vào Sheet1 vẫn vậy à, Anh xem lại giúp em.

Nãy để nhầm

Set change = Intersect(Target, Range("J2:J600000")) xét cột J mới đúng

 

[huonglien1901]

Nãy để nhầm

Set change = Intersect(Target, Range("J2:J600000")) xét cột J mới đúng

Anh có thể làm vào file gửi lên giúp em được không?

Em gán code vào cũng vậy à, ngày tháng đảo lộn.

 

[LamNA]

Anh có thể làm vào file gửi lên giúp em được không?

Em gán code vào cũng vậy à, ngày tháng đảo lộn.

File bài #11 đó chị

 

[huonglien1901]

File bài #11 đó chị

Em cảm ơn Anh nhiều!
làm phiền Anh tí định dạng ngày tháng cho nằm bên phía tay phải được không Anh?

Chúc Anh một buổi tối vui vẻ!

 

[LamNA]

Em cảm ơn Anh nhiều!
làm phiền Anh tí định dạng ngày tháng cho nằm bên phía tay phải được không Anh?

Chúc Anh một buổi tối vui vẻ!

Thì chị định dạng lại được mà

 

[HieuCD]

Anh Hiếu ơi!
Anh xem giúp em vấn đề này với. Định dạng ngày tháng bị lẫn lộn.(trong file em có định dạng màu để cho dễ nhận dạng)

Em cảm ơn Anh nhiều!

Tạo Function cho riêng bài nầy

Sub Main()
  Dim eRow As Long

  eRow = Range("I" & Rows.Count).Row
  If eRow > 1 Then
    Range("H2:H" & eRow).Value = Date_Change(Range("I2:I" & eRow).Value)
  End If
End Sub

Function Date_Change(ByVal sArr As Variant) As Variant
  Dim Res(), i As Long, sRow As Long

  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 1)
  For i = 1 To sRow
    tmp = sArr(i, 1)
    If TypeName(tmp) = "String" And Len(tmp) = 8 Then
      Res(i, 1) = DateValue(Mid(tmp, 7, 2) & "/" & Mid(tmp, 4, 2) & "/" & Mid(tmp, 1, 2))
    ElseIf IsDate(tmp) Then
      Res(i, 1) = DateValue(Year(tmp) & "/" & Day(tmp) & "/" & Month(tmp))
    End If
  Next i
  Date_Change = Res
End Function

 

[leonguyenz]

Tạo Function cho riêng bày nầy

Sub Main()
  Dim eRow As Long

  eRow = Range("I" & Rows.Count).Row
  If eRow > 1 Then
    Range("H2:H" & eRow).Value = Date_Change(Range("I2:I" & eRow).Value)
  End If
End Sub

Function Date_Change(ByVal sArr As Variant) As Variant
  Dim Res(), i As Long, sRow As Long

  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 1)
  For i = 1 To sRow
    tmp = sArr(i, 1)
    If TypeName(tmp) = "String" And Len(tmp) = 8 Then
      Res(i, 1) = DateValue(Mid(tmp, 7, 2) & "/" & Mid(tmp, 4, 2) & "/" & Mid(tmp, 1, 2))
    ElseIf IsDate(tmp) Then
      Res(i, 1) = DateValue(Year(tmp) & "/" & Day(tmp) & "/" & Month(tmp))
    End If
  Next i
  Date_Change = Res
End Function

Kết quả hình như chưa đạt phải không anh?

 

[HieuCD]

Kết quả hình như chưa đạt phải không anh?
View attachment 218440

Máy mình ra năm 2019
Thử thêm năm đầy đủ xem còn bị không

Function Date_Change(ByVal sArr As Variant) As Variant
  Dim Res(), i As Long, sRow As Long
 
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 1)
  For i = 1 To sRow
    tmp = sArr(i, 1)
    If TypeName(tmp) = "String" And Len(tmp) = 8 Then
      Res(i, 1) = DateValue(20 & Mid(tmp, 7, 2) & "/" & Mid(tmp, 4, 2) & "/" & Mid(tmp, 1, 2))
    ElseIf IsDate(tmp) Then
      Res(i, 1) = DateValue(Year(tmp) & "/" & Day(tmp) & "/" & Month(tmp))
    End If
  Next i
  Date_Change = Res
End Function