• Vui lòng đọc nội qui diễn đàn để tránh bị xóa bài viết
  • Tìm kiếm trước khi đặt câu hỏi

Nhờ anh chị sửa dùm em code VBA

Nơi trao đổi về VBA (Visual Basic for Application), lập trình cho ứng dụng Microsoft Office, AutoCAD...

Moderator: tungblt

heyhey1994
Posts: 1
Joined: Fri 07/06/2013 9:53 pm

Nhờ anh chị sửa dùm em code VBA

Postby heyhey1994 » Mon 23/07/2018 11:11 am

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("C22:D22")
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.



Return to “Visual Basic for Application (VBA)”

Who is online

Users browsing this forum: No registered users and 4 guests