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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
H

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
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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
heyhey1994 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
heyhey1994 đã viết:
Dạ cột A luôn luôn theo thứ tự tăng dần và ko có âm ạ
Nhấp chuột vào đây để mở rộng...
PacificPR đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...
Code này sẽ sai nếu cột A có số nguyên anh ạ!!!
 
Upvote 0
heyhey1994 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
PacificPR đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
eke_rula đã viết:
Code này sẽ sai nếu cột A có số nguyên anh ạ!!!
Nhấp chuột vào đây để mở rộng...
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
HieuCD đã viết:
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
Nhấp chuột vào đây để mở rộng...
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.
Nhấp chuột vào đây để mở rộng...
Đâ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
Hoang2013 đã viết:
Đâ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
Nhấp chuột vào đây để mở rộng...
Mình nhầm bài
 
Lần chỉnh sửa cuối:
Upvote 0
eke_rula đã viết:
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!!!
Nhấp chuột vào đây để mở rộng...

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
heyhey1994 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết (2 người xem)
Trả lời
0
Đọc
21
TramAnhNguyen692
T
S
NHỜ ANH EM GIÚP MÌNH TÌM KIẾM DỮ LIỆU (1 người xem)
Trả lời
11
Đọc
110
Duy Tùng 9x
Duy Tùng 9x
H
chuyển dữ liệu từ 1 dòng thành nhiều dòng,
Trả lời
8
Đọc
42
thuytrangbp28
T
V
Help: Hàm đếm lọc giá trị trùng (1 người xem)
Trả lời
11
Đọc
51
Duy Tùng 9x
Duy Tùng 9x
B
XIN HƯỚNG DẪN CÁCH ĐỂ HÀM XLOOKUP TỰ NHẢY THEO SỐ LƯỢNG DÒNG CỦA ĐIỀU KIỆN KHÔNG SỬ DỤNG VBA (1 người xem)
Trả lời
2
Đọc
28
Duy Tùng 9x
Duy Tùng 9x
C
Filter có điều kiện đang ở dạng Cột (2 người xem)
Trả lời
2
Đọc
40
thuytrangbp28
T
L
Có ai biết fix lỗi này không ạ
    • Buồn
Trả lời
2
Đọc
35
lekimhuy0812
L
tonny jj
Lập hàm thể hiện số công lệnh của ngày đi công tác
Trả lời
5
Đọc
167
Gà Công Nghệ
Gà Công Nghệ
GPE-Trợ Lý
[GPE] TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365 (1 người xem)
    • Thích
Trả lời
1
Đọc
3K
PhanTuHuong
PhanTuHuong
K
Lỗi cấu trúc hình ảnh khi mở file bằng điện thoại
Trả lời
0
Đọc
30
Kecodonlalala
K
N
  • Question Question
Nhờ mọi người góp ý cho file Quản lý bán hàng viết bằng VBA đầu tay của mình
    • Cảm ơn
    • Thích
Trả lời
7
Đọc
152
newbiexo
N
H
Xin được trợ giúp lỗi máy không mở được cửa sổ VBE.
Trả lời
3
Đọc
64
Nguyễn Duy Tuân
Nguyễn Duy Tuân
HeSanbi
  • Question Question
Sự khác nhau giữa book.Worksheets và book.Sheets trong Application
    • Thích
Trả lời
2
Đọc
141
Nguyễn Duy Tuân
Nguyễn Duy Tuân
PhanTuHuong
Hà Nội hẹn hò gặp gỡ đầu năm 2025 thôi :)
    • Thích
    • Yêu thích
Trả lời
7
Đọc
328
PhanTuHuong
PhanTuHuong
yeudoi
Cà phê giao lưu cùng thành viên kỳ cựu Cao Mạnh Sơn 19h 23/2/2025
    • Thích
    • Yêu thích
Trả lời
1
Đọc
69
PhanTuHuong
PhanTuHuong
DinhManh1307
Cách thống kê công việc sản xuất từng người để tính lương sản phẩm
Trả lời
8
Đọc
189
thuytrangbp28
T
K
Làm sao để ô excel hiển thị tên nhưng khi nhấp vào thì đó là công thức
Trả lời
1
Đọc
47
pycckuu410
P
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
41
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (3 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
15 16 17
Trả lời
326
Đọc
25K
pycckuu410
P
V
  • Question Question
Đếm xếp loại của đơn hàng
Trả lời
8
Đọc
233
vanlinh_2904
V
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom