Tại dãy số tăng dần theo danh sách số cho trước (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

heyhey1994

Thành viên chính thức
Tham gia
16/3/17
Bài viết
78
Được thích
17
Em có 1 dãy số hàng dọc ở cột A, bây giờ em em tạo 1 cái button, click cái là nó sẽ hiện ra như cột B. Anh chị nào giúp em với ạ :D
upload_2017-7-15_20-49-46.png
 
Cột a có chứa số âm không, giá trị của chúng có được sắp xếp trước không?
 
Upvote 0
Em có 1 dãy số hàng dọc ở cột A, bây giờ em em tạo 1 cái button, click cái là nó sẽ hiện ra như cột B. Anh chị nào giúp em với ạ :D
View attachment 179718
Bạn thử Code này xem sao
Mã:
Sub Taodayso()
    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
On Error GoTo Thoat
Set Dic = CreateObject("Scripting.Dictionary")
Set sRng = Application.InputBox(Prompt:="Chon vung du lieu ", Title:="Chon du lieu", Type:=8)
N = Application.InputBox("Nhap Stt cot chua so: ")
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
            If Int(sArr(I, N) / 10) - sArr(I, N) / 10 = 0 Then
                If I < UBound(sArr) Then
                    K = K + 1
                    For Col = 1 To N - 1
                        dArr(K, Col) = sArr(I + 1, Col)
                    Next Col
                    dArr(K, N) = sArr(I, N)
                End If
            End If
            Nt = Ns + 1
        End If
    End If
Next I
Set eRng = Application.InputBox(Prompt:="Chon o chua ket qua ", Title:="Chon cells", Type:=8)
eRng.Resize(1500, UBound(sArr, 2)).ClearContents
eRng.Resize(K, UBound(sArr, 2)) = dArr
Set Dic = Nothing
Thoat:
End Sub
P/s: Em sửa lại cho đúng đề bài 9
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Cho bạn thêm đoạn code:
PHP:
Sub lietke()
Dim num1 As Long, num2 As Long, rng1 As Range, arr1, arr2, arr3
Set rng1 = Range("A1:A" & [A60000].End(xlUp).Row)
arr2 = rng1
[B1:B60000].ClearContents
ReDim arr1(1 To Int(WorksheetFunction.Max(rng1)), 1 To 1), arr3(1 To rng1.Count, 1 To 1)
For num1 = 1 To UBound(arr1)
    arr1(num1, 1) = num1
Next num1
With CreateObject("scripting.dictionary")
    For num1 = 1 To UBound(arr2)
        If Int(arr2(num1, 1)) <> arr2(num1, 1) And Not .exists(arr2(num1, 1)) Then
            .Add arr2(num1, 1), "": num2 = num2 + 1
            arr3(num2, 1) = arr2(num1, 1)
        End If
    Next num1
End With
[B1].Resize(UBound(arr1), 1) = arr1
Cells(UBound(arr1) + 1, "B").Resize(UBound(arr3), 1) = arr3
[B1].Resize([B60000].End(xlUp).Row, 1).Sort key1:=[B1]
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Dạ cột A luôn luôn theo thứ tự tăng dần và ko có âm ạ
Bạn thử Code này xem sao
Mã:
Sub Taodayso()
    Dim sArr, dArr(1 To 65535, 1 To 1)
    Dim Dic As Object
    Dim I As Long, K As Long, J As Long, Nt As Long, Ns As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
    sArr = .Range("A1", .Range("A65535").End(3)).Value
    For I = 1 To UBound(sArr)
        If Not Dic.Exists(sArr(I, 1)) Then
            Dic.Add sArr(I, 1), ""
            If sArr(I, 1) <> Empty Then
                If sArr(I, 1) >= 1 Then
                    If I = 1 Then Nt = 1
                    Ns = Int(sArr(I, 1))
                    For J = Nt To Ns
                        K = K + 1
                        dArr(K, 1) = J
                    Next J
                End If
                If sArr(I, 1) > Int(sArr(I, 1)) Then
                    K = K + 1
                    dArr(K, 1) = sArr(I, 1)
                End If
                Nt = Ns + 1
            End If
        End If
    Next I
    .Range("B1:B" & .Range("B65535").End(3).Row + 1).ClearContents
    .Range("B1").Resize(K, 1) = dArr
End With
Set Dic = Nothing
End Sub
Do các số tăng dần nên không có sự trùng, không cần dùng Dic
Mã:
Sub Taodayso1()
    Dim Sarr, Darr(1 To 65535, 1 To 1)
    Dim i As Long, k As Long, n As Long
With Sheet1
    Sarr = .Range("A1", .Range("A65535").End(3)).Value
    n = 1
    For i = 1 To UBound(Sarr)
        If Sarr(i, 1) <> Empty Then
Tiep:
            k = k + 1
            If Sarr(i, 1) < n Then
                Darr(k, 1) = Sarr(i, 1)
            Else
                Darr(k, 1) = n
                n = n + 1
                If Sarr(i, 1) <> n Then GoTo Tiep
            End If
        End If
    Next i
    .Range("C1:C" & .Range("B65535").End(3).Row + 1).ClearContents
    .Range("C1").Resize(k, 1) = Darr
End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Do các số tăng dần nên không có sự trùng, không cần dùng Dic
Mã:
Sub Taodayso1()
    Dim Sarr, Darr(1 To 65535, 1 To 1)
    Dim i As Long, k As Long, n As Long
With Sheet1
    Sarr = .Range("A1", .Range("A65535").End(3)).Value
    n = 1
    For i = 1 To UBound(Sarr)
        If Sarr(i, 1) <> Empty Then
Tiep:
            k = k + 1
            If Sarr(i, 1) < n Then
                Darr(k, 1) = Sarr(i, 1)
            Else
                Darr(k, 1) = n
                n = n + 1
                GoTo Tiep
            End If
        End If
    Next i
    .Range("C1:C" & .Range("B65535").End(3).Row + 1).ClearContents
    .Range("C1").Resize(k, 1) = Darr
End With
End Sub
Dạ em đưa vào để phòng thôi anh ạ. :D. Code trên của anh hay quá anh ạ. Chúc anh một ngày cuối tuần vui vẻ
 
Upvote 0
Dạ em cảm ơn anh chị đã giúp em ạ. Tiện cho em hỏi là bây giờ có thêm 1 dòng tên phía trước thì có cách nào hiện ra 2 cột phía sau ạ, với lại nếu ô chuỗi số mà số tròn như 10 thì nó lặp lại 2 lần.
upload_2017-7-16_12-58-14.png
 
Lần chỉnh sửa cuối:
Upvote 0
Lần chỉnh sửa cuối:
Upvote 0
Do các số tăng dần nên không có sự trùng, không cần dùng Dic
Mã:
Sub Taodayso1()
    Dim Sarr, Darr(1 To 65535, 1 To 1)
    Dim i As Long, k As Long, n As Long
With Sheet1
    Sarr = .Range("A1", .Range("A65535").End(3)).Value
    n = 1
    For i = 1 To UBound(Sarr)
        If Sarr(i, 1) <> Empty Then
Tiep:
            k = k + 1
            If Sarr(i, 1) < n Then
                Darr(k, 1) = Sarr(i, 1)
            Else
                Darr(k, 1) = n
                n = n + 1
                If Sarr(i, 1) <> n Then GoTo Tiep
            End If
        End If
    Next i
    .Range("C1:C" & .Range("B65535").End(3).Row + 1).ClearContents
    .Range("C1").Resize(k, 1) = Darr
End With
End Sub
Code này sẽ sai nếu cột A có số nguyên anh ạ!!!
 
Upvote 0
Dạ em cảm ơn anh chị đã giúp em ạ. Tiện cho em hỏi là bây giờ có thêm 1 dòng tên phía trước thì có cách nào hiện ra 2 cột phía sau ạ, với lại nếu ô chuỗi số mà số tròn như 10 thì nó lặp lại 2 lần.
View attachment 179756
Cho bạn đoạn code:
PHP:
Sub lietke()
Dim num1 As Long, num2 As Long, num3 As Boolean, arr1, arr2
arr1 = Range("a1:b" & [a65000].End(xlUp).Row)
ReDim arr2(1 To 65000, 1 To 2)
[E1:F60000].ClearContents
num2 = 1
For num1 = 1 To UBound(arr1)
    num3 = True
nex:
    num2 = num2 + 1
    If num1 > 1 Then
        If num3 And arr1(num1 - 1, 2) / 10 = Int(arr1(num1 - 1, 2) / 10) Then
            arr2(num2, 2) = arr1(num1 - 1, 2)
            arr2(num2, 1) = arr1(num1, 1)
            num3 = False
            GoTo nex
        End If
    End If
    If Int(arr2(num2 - 1, 2)) + 1 < arr1(num1, 2) Then
        arr2(num2, 2) = Int(arr2(num2 - 1, 2)) + 1
        arr2(num2, 1) = arr1(num1, 1)
        GoTo nex
    Else
        arr2(num2, 2) = arr1(num1, 2)
        arr2(num2, 1) = arr1(num1, 1)
    End If
Next num1
[e1].Resize(num2, 2) = arr2
End Sub
 
Upvote 0
Bạn dùng cái này muốn thêm bao nhiêu cột vào cũng được
Mã:
Sub Taodayso()
    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
On Error GoTo Thoat
Set Dic = CreateObject("Scripting.Dictionary")
Set sRng = Application.InputBox(Prompt:="Chon vung du lieu ", Title:="Chon du lieu", Type:=8)
N = Application.InputBox("Nhap Stt cot chua so: ")
    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 = Application.InputBox(Prompt:="Chon o chua ket qua ", Title:="Chon cells", Type:=8)
    eRng.Resize(1500, UBound(sArr, 2)).ClearContents
    eRng.Resize(K, UBound(sArr, 2)) = dArr
Set Dic = Nothing
Thoat:
End Sub
Yêu cầu là những số nào chia hết cho 10 thì phải tạo ra 2 dòng bạn ạ, bạn xem file hình bài #9 xem!!!
 
Upvote 0
Code này sẽ sai nếu cột A có số nguyên anh ạ!!!
Vậy thì chỉnh tiếp, thêm xét loại trùng
Mã:
Sub Taodayso1()
    Dim Sarr, Darr(1 To 65535, 1 To 1)
    Dim i As Long, k As Long, n As Long, dk As Boolean
With Sheet1
    Sarr = .Range("A1", .Range("A65535").End(3)).Value
    n = 1
    For i = 1 To UBound(Sarr)
        If i < UBound(Sarr) Then dk = Sarr(i, 1) <> Sarr(i + 1, 1) Else dk = True
        If Sarr(i, 1) <> Empty And dk Then
Tiep:
            k = k + 1
            If Sarr(i, 1) < n Then
                Darr(k, 1) = Sarr(i, 1)
            Else
                Darr(k, 1) = n
                n = n + 1
                If Sarr(i, 1) <> n - 1 Then GoTo Tiep
            End If
        End If
    Next i
    .Range("C1:C" & .Range("B65535").End(3).Row + 1).ClearContents
    .Range("C1").Resize(k, 1) = Darr
End With
End Sub
 
Upvote 0
Vậy thì chỉnh tiếp, thêm xét loại trùng
Mã:
Sub Taodayso1()
    Dim Sarr, Darr(1 To 65535, 1 To 1)
    Dim i As Long, k As Long, n As Long, dk As Boolean
With Sheet1
    Sarr = .Range("A1", .Range("A65535").End(3)).Value
    n = 1
    For i = 1 To UBound(Sarr)
        If i < UBound(Sarr) Then dk = Sarr(i, 1) <> Sarr(i + 1, 1) Else dk = True
        If Sarr(i, 1) <> Empty And dk Then
Tiep:
            k = k + 1
            If Sarr(i, 1) < n Then
                Darr(k, 1) = Sarr(i, 1)
            Else
                Darr(k, 1) = n
                n = n + 1
                If Sarr(i, 1) <> n - 1 Then GoTo Tiep
            End If
        End If
    Next i
    .Range("C1:C" & .Range("B65535").End(3).Row + 1).ClearContents
    .Range("C1").Resize(k, 1) = Darr
End With
End Sub
Theo tôi sẽ viết code như sau
Tạo day số từ 1 đến trúnc( max) của range
Gán dãy số đó vào cột b
Copy range hiện tại vào dưới dãy số vừa tạo.
Dùng remove duplicate hoặc advanced filter Để lấy Duy nhất
Sort A_z
Có ngay kết quả.
 
Upvote 0
. . . Tiện cho em hỏi là bây giờ có thêm 1 dòng tên phía trước thì có cách nào hiện ra 2 cột phía sau ạ, với lại nếu ô chuỗi số mà số tròn như 10 thì nó lặp lại 2 lần.
Đây là 1 cách thô sơ nè:
PHP:
Sub TaoDaySoTangDan()
 Dim Rws As Long, Max_ As Long, J As Long, W As Long, Num As Double, Dm As Integer
 Dim Arr():                                 Dim Ma As String
 
 Arr() = [B1].CurrentRegion.Value
 Rws = UBound(Arr()):                       Dm = 1
 [d1].CurrentRegion.ClearContents
 Max_ = Arr(Rws, 2) \ 1
 ReDim dArr(1 To Rws * Max_, 1 To 2)
 Ma = Arr(Dm, 1):                           Num = Arr(Dm, 2)
 For J = 1 To Max_
    W = W + 1
    dArr(W, 1) = Ma:                        dArr(W, 2) = J
    If J >= Num Then
        Dm = Dm + 1
        Ma = Arr(Dm, 1):                    Num = Arr(Dm, 2)
    End If
 Next J
 [d1].Resize(Rws, 2).Value = Arr()
 [D65500].End(xlUp).Offset(1).Resize(W, 2).Value = dArr()
End Sub
 
Upvote 0
Đây là 1 cách thô sơ nè:
PHP:
Sub TaoDaySoTangDan()
 Dim Rws As Long, Max_ As Long, J As Long, W As Long, Num As Double, Dm As Integer
 Dim Arr():                                 Dim Ma As String
 
 Arr() = [B1].CurrentRegion.Value
 Rws = UBound(Arr()):                       Dm = 1
 [d1].CurrentRegion.ClearContents
 Max_ = Arr(Rws, 2) \ 1
 ReDim dArr(1 To Rws * Max_, 1 To 2)
 Ma = Arr(Dm, 1):                           Num = Arr(Dm, 2)
 For J = 1 To Max_
    W = W + 1
    dArr(W, 1) = Ma:                        dArr(W, 2) = J
    If J >= Num Then
        Dm = Dm + 1
        Ma = Arr(Dm, 1):                    Num = Arr(Dm, 2)
    End If
 Next J
 [d1].Resize(Rws, 2).Value = Arr()
 [D65500].End(xlUp).Offset(1).Resize(W, 2).Value = dArr()
End Sub
Mình nhầm bài
 
Lần chỉnh sửa cuối:
Upvote 0
Yêu cầu là những số nào chia hết cho 10 thì phải tạo ra 2 dòng bạn ạ, bạn xem file hình bài #9 xem!!!

Chủ thớt không biết cách diễn tả số. Từ "tròn" có nghĩa là số chia chẵn cho 10 hay số không có thập phân? Ví dụ đúng vào chỗ khó hiểu.
 
Upvote 0
Dạ em cảm ơn anh chị đã giúp em ạ. Tiện cho em hỏi là bây giờ có thêm 1 dòng tên phía trước thì có cách nào hiện ra 2 cột phía sau ạ, với lại nếu ô chuỗi số mà số tròn như 10 thì nó lặp lại 2 lần.
View attachment 179756
Mã:
Sub Taodayso()
    Dim Sarr, Darr(1 To 65535, 1 To 2)
    Dim i As Long, k As Long, n As Long, dk As Boolean
    Sarr = Range("A1", Range("B65535").End(3)).Value
    n = 1
    For i = 1 To UBound(Sarr)
Tiep:
        k = k + 1
        If Sarr(i, 2) < n Then
            Darr(k, 1) = Sarr(i, 1): Darr(k, 2) = Sarr(i, 2)
        Else
            Darr(k, 1) = Sarr(i, 1): Darr(k, 2) = n
            n = n + 1
            If Sarr(i, 2) <> n - 1 Then
                GoTo Tiep
            Else
                If (Sarr(i, 2) Mod 10 = 0) And i < UBound(Sarr) Then
                    k = k + 1
                    Darr(k, 1) = Sarr(i + 1, 1): Darr(k, 2) = Sarr(i, 2)
                End If
            End If
        End If
    Next i
    Range("D1:E" & Range("D65535").End(3).Row + 1).ClearContents
    Range("D1").Resize(k, 2) = Darr
End Sub
 
Upvote 0
Theo tôi sẽ viết code như sau
Tạo day số từ 1 đến trúnc( max) của range
Gán dãy số đó vào cột b
Copy range hiện tại vào dưới dãy số vừa tạo.
Dùng remove duplicate hoặc advanced filter Để lấy Duy nhất
Sort A_z
Có ngay kết quả.
Thích cách này nhất! Đơn giản, thuần Excel, ai cũng làm được và thậm chí làm bằng tay cũng xong
 
Upvote 0
Thích cách này nhất! Đơn giản, thuần Excel, ai cũng làm được và thậm chí làm bằng tay cũng xong

Tôi nghĩ là các bạn ở đây chỉ viết code chơi cho vui thôi. Chứ loại bài dữ liệu quái đản thế này tôi phải hỏi lại dùng làm gì trước khi thực sự phân tích cách giải.
Lắm lúc nắm được mục đích rồi thì cách làm khác hoàn toàn.
 
Upvote 0
Gải thuật thô: nhìn sơ qua thì đề bài là một khoảng số, với nhiều khoảng con không đều nhau. Thêm điều kiện là các khoảng con bắt đầu bằng một số nguyên nhưng kết thúc là số thập phân.
Sau đó, chủ thớt thêm điều kiện nếu khoảng con kết thúc là số nguyên thì khoảng con kế tiếp cũng bắt đầu từ số nguyên ấy (thay vì số nguyên kế tiếp).

Code thô để diễn tả giải thuật trên. Gồm 2 vòng lặp, vòng ngoài duyệt qua khoảng mẹ để lấy từng khoảng con, và vòng trong duyệt qua mỗi khoảng con.
Chỉ cần để ý 3 chỗ:
Chỗ thứ nhất là vì điểm cuối cùng của khoảng con có thể là số thập phân cho nên vòng lặp duyệt khoảng con phải tìm một số nguyên bao qua trị này. (hàm ceiling)
Chỗ thứ ba là vì có vấn đề "số nguyên bao qua" cho nên lúc chép sô phải xét lại xem nó có phải là số bao qua hay không (hàm IIf(num > valIn...))
Chỗ thứ ba là vì vòng lặp for kết thúc khi chỉ số đếm vượt qua điểm cuối. Vì vậy, sau khi dứt vòng con thì lấy chỉ số này trừ đi 1 sẽ ra điểm bắt đầu của khoảng con kế tiếp. (numStrt = num - 1)

Mã:
Sub ChaHieuMucDich()
Dim aIn, aOut(1 To 65535, 1 To 2)
Dim iIn As Long, iOut As Long, numStrt As Long, num As Long
Dim valIn As Double
aIn = Range("A1", Range("A65535").End(3)).Resize(, 2).Value
numStrt = 1
For iIn = 1 To UBound(aIn) ' duyet lay tung khoang con
    valIn = aIn(iIn, 2)
    For num = numStrt To Application.Ceiling(valIn, 1) ' duyet khoang con
        iOut = iOut + 1
        aOut(iOut, 1) = aIn(iIn, 1)
        aOut(iOut, 2) = IIf(num > valIn, valIn, num) ' ghi cho dung tri
    Next num
    numStrt = num - 1
    ' muon thu chia 10 gi gi do thi thu va chinh sua numStrt o day
Next iIn
Range("c1").Resize(iOut, 2) = aOut
End Sub
 
Upvote 0
Em cảm ơn tất cả anh chị giúp em ạ. :) Cuối cùng em cũng làm xong bảng tính của mình rồi. Hôm nay sực nhớ là chưa có lên cảm ơn nên giờ quay lại cảm ơn :D Chúc anh chị có 1 tuần làm việc tốt lành :)
 
Upvote 0

Bài viết mới nhất

Back
Top Bottom