Nhờ chỉnh lại code VBA.

[heyhey1994]

Sub Taodayso()

Range("C22:U9999").Select
Selection.Delete Shift:=xlUp

Dim sArr, dArr, sRng As Range, eRng As Range
Dim Dic As Object
Dim i As Long, K As Long, j As Long, Col As Long, N As Long, Nt As Long, Ns As Long, sodong As Long, demdong As Long, t As Long
On Error GoTo Thoat
Set Dic = CreateObject("Scripting.Dictionary")
Set sRng = Sheet1.Range("X22:Y99")
N = 2
sArr = sRng.Value
ReDim dArr(1 To 65535, 1 To UBound(sArr, 2))
For i = 1 To UBound(sArr)
If Not Dic.Exists(sArr(i, N)) Then
Dic.Add sArr(i, N), ""
If sArr(i, N) <> Empty Then
If sArr(i, 1) >= 1 Then
If i = 1 Then Nt = 1
Ns = Int(sArr(i, N))
For j = Nt To Ns
K = K + 1
For Col = 1 To N - 1
dArr(K, Col) = sArr(i, Col)
Next Col
dArr(K, N) = j
Next j
End If
If sArr(i, N) > Int(sArr(i, N)) Then
K = K + 1
For Col = 1 To N - 1
dArr(K, Col) = sArr(i, Col)
Next Col
dArr(K, N) = sArr(i, N)
End If
Nt = Ns + 1
End If
End If
Next i
Set eRng = Sheet1.Range("C2222")
eRng.Resize(1500, UBound(sArr, 2)).ClearContents
eRng.Resize(K, UBound(sArr, 2)) = dArr
Set Dic = Nothing
Thoat:
Trong đây là bản VBA em tìm trên mạng chia dãy số cho trước thành 1 đoạn nhỏ nhưng nó chỉ chia cho từng đoạn 1. Ví dụ 5.3 thành 1 1 1 1 1.3. Có cách nào sửa code này để chia thành đoạn 0.5 hoặc 2 ... tùy mình chỉnh được ko ạ.
em cảm ơn.

 

[quanluu]

Sub Taodayso()

Range("C22:U9999").Select
Selection.Delete Shift:=xlUp

Dim sArr, dArr, sRng As Range, eRng As Range
Dim Dic As Object
Dim i As Long, K As Long, j As Long, Col As Long, N As Long, Nt As Long, Ns As Long, sodong As Long, demdong As Long, t As Long
On Error GoTo Thoat
Set Dic = CreateObject("Scripting.Dictionary")
Set sRng = Sheet1.Range("X22:Y99")
N = 2
sArr = sRng.Value
ReDim dArr(1 To 65535, 1 To UBound(sArr, 2))
For i = 1 To UBound(sArr)
If Not Dic.Exists(sArr(i, N)) Then
Dic.Add sArr(i, N), ""
If sArr(i, N) <> Empty Then
If sArr(i, 1) >= 1 Then
If i = 1 Then Nt = 1
Ns = Int(sArr(i, N))
For j = Nt To Ns
K = K + 1
For Col = 1 To N - 1
dArr(K, Col) = sArr(i, Col)
Next Col
dArr(K, N) = j
Next j
End If
If sArr(i, N) > Int(sArr(i, N)) Then
K = K + 1
For Col = 1 To N - 1
dArr(K, Col) = sArr(i, Col)
Next Col
dArr(K, N) = sArr(i, N)
End If
Nt = Ns + 1
End If
End If
Next i
Set eRng = Sheet1.Range("C2222")
eRng.Resize(1500, UBound(sArr, 2)).ClearContents
eRng.Resize(K, UBound(sArr, 2)) = dArr
Set Dic = Nothing
Thoat:
Trong đây là bản VBA em tìm trên mạng chia dãy số cho trước thành 1 đoạn nhỏ nhưng nó chỉ chia cho từng đoạn 1. Ví dụ 5.3 thành 1 1 1 1 1.3. Có cách nào sửa code này để chia thành đoạn 0.5 hoặc 2 ... tùy mình chỉnh được ko ạ.
em cảm ơn.

Bạn đưa cái file mẫu với dữ liệu ban đầu và kết quả mẫu xem nó như thế nào. Chứ đọc code trên mệt lắm.

 

[heyhey1994]

Dạ đây ạ. Nó lấy số liệu cột A B để xuất ra cột C D.

 

[huuthang_bd]

Function TaoDay(aTenLop As Variant, aDoSau As Variant, BuocNhay As Double) As Variant
Dim aKetQua() As Variant, aKetQuaTam() As Variant, DoSau As Double, i As Long, n As Long
ReDim aKetQuaTam(1 To Int(aDoSau(UBound(aDoSau, 1), 1) / BuocNhay) + UBound(aDoSau, 1), 1 To 2)
For i = 1 To UBound(aDoSau, 1)
    Do While DoSau + BuocNhay < aDoSau(i, 1)
        n = n + 1
        DoSau = DoSau + BuocNhay
        aKetQuaTam(n, 1) = aTenLop(i, 1)
        aKetQuaTam(n, 2) = DoSau
    Loop
    n = n + 1
    aKetQuaTam(n, 1) = aTenLop(i, 1)
    aKetQuaTam(n, 2) = aDoSau(i, 1)
    If aDoSau(i, 1) = DoSau + BuocNhay Then DoSau = DoSau + BuocNhay
Next
ReDim aKetQua(1 To n, 1 To 2)
For i = 1 To n
    aKetQua(i, 1) = aKetQuaTam(i, 1)
    aKetQua(i, 2) = aKetQuaTam(i, 2)
Next
TaoDay = aKetQua
End Function

 

[heyhey1994]

Function TaoDay(aTenLop As Variant, aDoSau As Variant, BuocNhay As Double) As Variant
Dim aKetQua() As Variant, aKetQuaTam() As Variant, DoSau As Double, i As Long, n As Long
ReDim aKetQuaTam(1 To Int(aDoSau(UBound(aDoSau, 1), 1) / BuocNhay) + UBound(aDoSau, 1), 1 To 2)
For i = 1 To UBound(aDoSau, 1)
    Do While DoSau + BuocNhay < aDoSau(i, 1)
        n = n + 1
        DoSau = DoSau + BuocNhay
        aKetQuaTam(n, 1) = aTenLop(i, 1)
        aKetQuaTam(n, 2) = DoSau
    Loop
    n = n + 1
    aKetQuaTam(n, 1) = aTenLop(i, 1)
    aKetQuaTam(n, 2) = aDoSau(i, 1)
    If aDoSau(i, 1) = DoSau + BuocNhay Then DoSau = DoSau + BuocNhay
Next
ReDim aKetQua(1 To n, 1 To 2)
For i = 1 To n
    aKetQua(i, 1) = aKetQuaTam(i, 1)
    aKetQua(i, 2) = aKetQuaTam(i, 2)
Next
TaoDay = aKetQua
End Function

Mình cảm ơn ạ, nhưng bạn hướng dẫn mình cách dùng đc ko ạ? Mình nhập công thức là C1 =taoday(A1:A4,B1:B4,1) với cột A là Tên lớp cột B là độ sâu nhưng ko ra kết quả ạ?

 

[huuthang_bd]

Mình cảm ơn ạ, nhưng bạn hướng dẫn mình cách dùng đc ko ạ? Mình nhập công thức là C1 =taoday(A1:A4,B1:B4,1) với cột A là Tên lớp cột B là độ sâu nhưng ko ra kết quả ạ?
View attachment 200364 View attachment 200365

Hàm đó tôi viết để dùng trong VBA và là hàm mảng. Bạn muốn dùng trên sheet thì phải chuyển Range thành mảng và dùng với dạng công thức mảng. Như hình của bạn thì dùng như sau:
1. Chọn C130
2. Nhập công thức bên dưới sau đó nhấn Ctrl + Shift + Enter.

=TaoDay(A1:A4&"",B1:B4*1,1)

 

[heyhey1994]

Ok mình đã làm được ạ. Mình cảm ơn nhiều. Chúc một ngày tốt lành