Lấy giá trị ngày tháng bằng vba thay hàm index trong excel (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)
T

thufpts

Thành viên hoạt động
Tham gia
6/8/12
Bài viết
157
Được thích
6
Giới tính
Nam
Nghề nghiệp
Bốc vác
Chào các bác. em có một vấn đề này xin đệ trình với các bác. em có một dòng là ngày tháng là dòng thứ 5 từ Q5 đến AF5
1)khi em nhập một số bất kỳ ví dụ nhập 2 48 10 nó sẽ tự động lấy các ngày tương ứng là 7-Now, 7-Now, 7 Now từ dòng thứ 5 để trả về cột N đối xứng với các số đã nhập.
2) chỉ tính đối với ô đâu tiên được nhập sẽ lấy được giá trị ngày tháng còn ô đứng sau nếu có giá trị sẽ bỏ qua.
ví dụ em nhập 22 vào R9 thì ngày 8-Now sẽ được trả về N9 còn giá trị 14 đứng sau 22 sẽ ko lấy dc ngày tháng.
Với khả năng của em thì em chỉ có thể dùng hàm mặc định trong excel là index(). nhưng bản thân em viết ra được nhưng đến khi có lỗi em ko sửa được vì dối mắt lắm.
kính mong các bác giúp em.

Capture.jpg
 

File đính kèm

Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
thufpts đã viết:
Bác có thể tùy chỉnh được code để khi em thay đổi code đặt ngày tháng và đặt vị trí được không. chẳng hạn em không muốn đặt 2 cột vị trí và ngày tháng gần nhau mà đặt vị trí tại cột L và ngày tháng tại cột N thì làm thế nào. mong bác giúp em
Nhấp chuột vào đây để mở rộng...
bạn thay code mới
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("$Q$6:$AF$1000"), Target) Is Nothing Then Call GPE
End Sub
Mã: 
Sub GPE()
Dim Darr(), Ngay(1 To 1000, 1 To 1), ViTri(1 To 1000, 1 To 1), tmp As String, i As Long, j As Integer, n As Integer
Darr = Range("Q5:AF1000").Value
tmp = Range("K4").Value
For i = 2 To UBound(Darr) Step 1
    For j = 1 To UBound(Darr, 2) Step 1
        If Darr(i, j) > 0 Then
            ViTri(i - 1, 1) = tmp
            Ngay(i - 1, 1) = Darr(1, j)
            Exit For
        End If
    Next j
    If Ngay(i - 1, 1) = "" Then n = n + 1
    If n = 200 Then Exit For
Next i
Application.ScreenUpdating = False
Range("M6:M1000").ClearContents:    Range("N6:N1000").ClearContents
Range("M6").Resize(i - 1) = ViTri:  Range("N6").Resize(i - 1) = Ngay
Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
bạn thay code mới
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("$Q$6:$AF$1000"), Target) Is Nothing Then Call GPE
End Sub
Mã: 
Sub GPE()
Dim Darr(), Ngay(1 To 1000, 1 To 1), ViTri(1 To 1000, 1 To 1), tmp As String, i As Long, j As Integer, n As Integer
Darr = Range("Q5:AF1000").Value
tmp = Range("K4").Value
For i = 2 To UBound(Darr) Step 1
    For j = 1 To UBound(Darr, 2) Step 1
        If Darr(i, j) > 0 Then
            ViTri(i - 1, 1) = tmp
            Ngay(i - 1, 1) = Darr(1, j)
            Exit For
        End If
    Next j
    If Ngay(i - 1, 1) = "" Then n = n + 1
    If n = 200 Then Exit For
Next i
Application.ScreenUpdating = False
Range("M6:M1000").ClearContents:    Range("N6:N1000").ClearContents
Range("M6").Resize(i - 1) = ViTri:  Range("N6").Resize(i - 1) = Ngay
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
cam ơn bác. chạy ổn rồi bác ạ
 
Upvote 0
thufpts đã viết:
hay thật chỉ với vài đường cơ bản của bác mà nó chạy ngon. nhưng khi em xóa 1 vài ô màu đỏ nó lại báo lỗi bác ạ. bác xem giúp em với
Nhấp chuột vào đây để mở rộng...
bác ơi bác xem giúp em với đoạn code màu đỏ mỗi khi em copy nhiều dòng là nó lại giật bác ạ. mà nó giật 1 lúc nó mới thôi. có các nào khắc chế nó không bác.
 
Upvote 0
HieuCD đã viết:
code màu đỏ là mới thêm vào, còn lại là code của bạn
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("$Q$6:$AF$1000"), Target) Is Nothing Then
        If Target.Count = 1 Then
            Call GPE
        End If
    End If
[COLOR=#ff0000]    If Not Intersect(Target, Range("$P$6:$P$1000")) Is Nothing Then[/COLOR]
[COLOR=#ff0000]        If Target.Value <> "" Then[/COLOR]
[COLOR=#ff0000]            Cells(Target.Row, "M") = Range("K4").Value[/COLOR]
[COLOR=#ff0000]        Else[/COLOR]
[COLOR=#ff0000]            Cells(Target.Row, "M") = ""[/COLOR]
[COLOR=#ff0000]        End If[/COLOR]
[COLOR=#ff0000]    End If[/COLOR]
End Sub
Nhấp chuột vào đây để mở rộng...
bác ơi bác xem giúp em với đoạn code màu đỏ mỗi khi em copy nhiều dòng là nó lại giật bác ạ. mà nó giật 1 lúc nó mới thôi. có các nào khắc chế nó không bác.
 
Upvote 0
HieuCD đã viết:
muốn xử nhiều ô thì dùng code sau
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("$Q$6:$AF$1000"), Target) Is Nothing Then
        If Target.Count = 1 Then
            Call GPE
        End If
    End If
[COLOR=#ff0000]    If Not Intersect(Target, Range("$P$6:$P$1000")) Is Nothing Then[/COLOR]
[COLOR=#ff0000]        For i = Target.Row To Target.Row + Target.Rows.Count - 1 Step 1[/COLOR]
[COLOR=#ff0000]            If Cells(i, "P").Value <> "" Then[/COLOR]
[COLOR=#ff0000]                Cells(i, "M") = Range("K4").Value[/COLOR]
[COLOR=#ff0000]            Else[/COLOR]
[COLOR=#ff0000]                Cells(i, "M") = ""[/COLOR]
[COLOR=#ff0000]            End If[/COLOR]
[COLOR=#ff0000]        Next i[/COLOR]
[COLOR=#ff0000]    End If[/COLOR]
End Sub
Nhấp chuột vào đây để mở rộng...
xin Lỗi bác em gửi lại câu hỏi. đoạn code màu đỏ của bác. có thể cho nó ra thành 1 sub khác. mỗi khi em copy nhiều dòng là nó giật. đoạn code trước bác viết nó chạy rất ổn. chỉ còn cái này em muốn áp dụng cho thêm 1 cột P khi có giá trị thì cột M sẽ nhận giá trị (Vị trí B)
 
Lần chỉnh sửa cuối:
Upvote 0
thufpts đã viết:
bác ơi bác xem giúp em với đoạn code màu đỏ mỗi khi em copy nhiều dòng là nó lại giật bác ạ. mà nó giật 1 lúc nó mới thôi. có các nào khắc chế nó không bác.
Nhấp chuột vào đây để mở rộng...
nó bị đụng với sub GPE() hoặc code khác
để khắc phục tạm thì bạn thêm lệnh

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Range("$Q$6:$AF$1000"), Target) Is Nothing Then
If Target.Count = 1 Then
Call GPE
End If
End If
If Not Intersect(Target, Range("$P$6:$P$1000")) Is Nothing Then
If Target.Value <> "" Then
Cells(Target.Row, "M") = Range("K4").Value
Else
Cells(Target.Row, "M") = ""
End If
End If
Application.ScreenUpdating = True
End Sub
tốt nhất là đưa toàn bộ code hoặc file mới chỉnh cho chạy nhanh được
 
Upvote 0
thufpts đã viết:
xin Lỗi bác em gửi lại câu hỏi. đoạn code màu đỏ của bác. có thể cho nó ra thành 1 sub khác. mỗi khi em copy nhiều dòng là nó giật. đoạn code trước bác viết nó chạy rất ổn. chỉ còn cái này em muốn áp dụng cho thêm 1 cột P khi có giá trị thì cột M sẽ nhận giá trị (Vị trí B)
Nhấp chuột vào đây để mở rộng...
bạn thêm 2 lệnh để chống giật
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
[COLOR=#ff0000]    Application.ScreenUpdating = False[/COLOR]
    If Not Intersect(Range("$Q$6:$AF$1000"), Target) Is Nothing Then
        If Target.Count = 1 Then
            Call GPE
        End If
    End If
    If Not Intersect(Target, Range("$P$6:$P$1000")) Is Nothing Then
        For i = Target.Row To Target.Row + Target.Rows.Count - 1 Step 1
            If Cells(i, "P").Value <> "" Then
                Cells(i, "M") = Range("K4").Value
            Else
                Cells(i, "M") = ""
            End If
        Next i
    End If
[COLOR=#ff0000]    Application.ScreenUpdating = True[/COLOR]
End Sub
 
Upvote 0
HieuCD đã viết:
bạn thêm 2 lệnh để chống giật
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
[COLOR=#ff0000]    Application.ScreenUpdating = False[/COLOR]
    If Not Intersect(Range("$Q$6:$AF$1000"), Target) Is Nothing Then
        If Target.Count = 1 Then
            Call GPE
        End If
    End If
    If Not Intersect(Target, Range("$P$6:$P$1000")) Is Nothing Then
        For i = Target.Row To Target.Row + Target.Rows.Count - 1 Step 1
            If Cells(i, "P").Value <> "" Then
                Cells(i, "M") = Range("K4").Value
            Else
                Cells(i, "M") = ""
            End If
        Next i
    End If
[COLOR=#ff0000]    Application.ScreenUpdating = True[/COLOR]
End Sub
Nhấp chuột vào đây để mở rộng...
Chuẩn luôn. bác quá pro
 
Upvote 0
HieuCD đã viết:
nó bị đụng với sub GPE() hoặc code khác
để khắc phục tạm thì bạn thêm lệnh

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Range("$Q$6:$AF$1000"), Target) Is Nothing Then
...
End If
Application.ScreenUpdating = True
End Sub
tốt nhất là đưa toàn bộ code hoặc file mới chỉnh cho chạy nhanh được
Nhấp chuột vào đây để mở rộng...

Bị đụng code thì bạn phải dùng cách trữ và phục hồi nguyên trạng

Private Sub Worksheet_Change(ByVal Target As Range)
dim screenStatus as Boolean
screenStatus = Application.ScreenUpdating
Application.ScreenUpdating = False
If Not Intersect(Range("$Q$6:$AF$1000"), Target) Is Nothing Then
...
End If
Application.ScreenUpdating = screenStatus
End Sub
 
Upvote 0
VetMini đã viết:
Bị đụng code thì bạn phải dùng cách trữ và phục hồi nguyên trạng

Private Sub Worksheet_Change(ByVal Target As Range)
dim screenStatus as Boolean
screenStatus = Application.ScreenUpdating
Application.ScreenUpdating = False
If Not Intersect(Range("$Q$6:$AF$1000"), Target) Is Nothing Then
...
End If
Application.ScreenUpdating = screenStatus
End Sub
Nhấp chuột vào đây để mở rộng...
Em có làm Như Bác VietMini Và bác HieuCD nhưng nó vẫn giật. khi xóa 1 vùng ở cột P thì không sao nhưng mà khi em xóa cả cột P thì nó quay
và nó giật không dừng được. Mong các bác xem giúp em với
 

File đính kèm

Upvote 0
Tôi giới thiệu cách tránh đụng code trong trường hợp như vầy:

Sub subMe
screenupdating đặt là false ở đây
code...
gọi subCon
code...
screenupdating đặt true ở đây
End Sub

Sub subCon
screenupdating đặt là false ở đây
code...
screenupdating đặt true ở đây
End Sub

Đọc kỹ thứ tự vận hành code, bạn sẽ thấy screenupdating được đặt true trước khi code của subMe chạy xong. Việc save và recover biến/thuộc tính toàn cục sẽ tránh được việc thuộc tính bị biến đổi ngàoi ý muốn.
(screenupdating là mộ thuộc ính của Application, tức là nó toàn cục 100%)

Việc bạn bị giật có thể do ở sub khác hoặc nguyên do khác.
 
Upvote 0
VetMini đã viết:
Tôi giới thiệu cách tránh đụng code trong trường hợp như vầy:

Sub subMe
screenupdating đặt là false ở đây
code...
gọi subCon
code...
screenupdating đặt true ở đây
End Sub

Sub subCon
screenupdating đặt là false ở đây
code...
screenupdating đặt true ở đây
End Sub

Đọc kỹ thứ tự vận hành code, bạn sẽ thấy screenupdating được đặt true trước khi code của subMe chạy xong. Việc save và recover biến/thuộc tính toàn cục sẽ tránh được việc thuộc tính bị biến đổi ngàoi ý muốn.
(screenupdating là mộ thuộc ính của Application, tức là nó toàn cục 100%)

Việc bạn bị giật có thể do ở sub khác hoặc nguyên do khác.
Nhấp chuột vào đây để mở rộng...
Nói thật là em chẳng biết gì về code cả. giỏi lắm thì em chỉ thay đổi vị trí đặt các cột và ô thôi. Nên rất mong các bác có cách nào khắc phục được.
 
Upvote 0
thufpts đã viết:
Em có làm Như Bác VietMini Và bác HieuCD nhưng nó vẫn giật. khi xóa 1 vùng ở cột P thì không sao nhưng mà khi em xóa cả cột P thì nó quay
và nó giật không dừng được. Mong các bác xem giúp em với
Nhấp chuột vào đây để mở rộng...
cứ nghĩ bạn chỉ xóa vài ô, ai dè bạn xóa nguyên cột.
bạn dùng code mới
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
        If Not Intersect(Target, Range("$Q$6:$AF$1000")) Is Nothing Then Call GPE
        If Not Intersect(Target, Range("$P$6:$P$1000")) Is Nothing Then Call VT
End Sub
Mã: 
Option Explicit
Sub GPE()
    Dim Darr(), Ngay(1 To 1000, 1 To 1), Vitri(1 To 1000, 1 To 1), tmp As String, i As Long, j As Integer, n As Integer
    Darr = Range("Q5:AF1000").Value
    tmp = Range("C3").Value
        For i = 2 To UBound(Darr) Step 1
            For j = 1 To UBound(Darr, 2) Step 1
                If Darr(i, j) > 0 Then
                    Vitri(i - 1, 1) = tmp
                    Ngay(i - 1, 1) = Darr(1, j)
                    Exit For
                End If
            Next j
            If Ngay(i - 1, 1) = "" Then n = n + 1
            If n = 200 Then Exit For
        Next i
        Application.ScreenUpdating = False
        Range("L6:L1000").ClearContents:    Range("N6:N1000").ClearContents
        Range("L6").Resize(i - 1) = Vitri:  Range("N6").Resize(i - 1) = Ngay
        Application.ScreenUpdating = True
End Sub
Sub VT()
    Dim i As Long, Darr(), Vitri(1 To 1000, 1 To 1), tmp As String
    Darr = Range("P6:P1000").Value
    tmp = Range("C3").Value
    For i = 1 To UBound(Darr) Step 1
        If Darr(i, 1) <> "" Then Vitri(i, 1) = tmp
    Next i
    Application.ScreenUpdating = False
    Range("M6:M1000").ClearContents
    Range("M6").Resize(i - 1) = Vitri
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
cứ nghĩ bạn chỉ xóa vài ô, ai dè bạn xóa nguyên cột.
bạn dùng code mới
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
        If Not Intersect(Target, Range("$Q$6:$AF$1000")) Is Nothing Then Call GPE
        If Not Intersect(Target, Range("$P$6:$P$1000")) Is Nothing Then Call VT
End Sub
Mã: 
Option Explicit
Sub GPE()
    Dim Darr(), Ngay(1 To 1000, 1 To 1), Vitri(1 To 1000, 1 To 1), tmp As String, i As Long, j As Integer, n As Integer
    Darr = Range("Q5:AF1000").Value
    tmp = Range("C3").Value
        For i = 2 To UBound(Darr) Step 1
            For j = 1 To UBound(Darr, 2) Step 1
                If Darr(i, j) > 0 Then
                    Vitri(i - 1, 1) = tmp
                    Ngay(i - 1, 1) = Darr(1, j)
                    Exit For
                End If
            Next j
            If Ngay(i - 1, 1) = "" Then n = n + 1
            If n = 200 Then Exit For
        Next i
        Application.ScreenUpdating = False
        Range("L6:L1000").ClearContents:    Range("N6:N1000").ClearContents
        Range("L6").Resize(i - 1) = Vitri:  Range("N6").Resize(i - 1) = Ngay
        Application.ScreenUpdating = True
End Sub
Sub VT()
    Dim i As Long, Darr(), Vitri(1 To 1000, 1 To 1), tmp As String
    Darr = Range("P6:P1000").Value
    tmp = Range("C3").Value
    For i = 1 To UBound(Darr) Step 1
        If Darr(i, 1) <> "" Then Vitri(i, 1) = tmp
    Next i
    Application.ScreenUpdating = False
    Range("M6:M1000").ClearContents
    Range("M6").Resize(i - 1) = Vitri
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Tạ ơn bác. lần này thì không lệch đi đâu được. Đa tạ bác
 
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

SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng (1 người xem)
Trả lời
10
Đọc
165
VetMini
V
A
  • Question Question
Nhờ anh chị em chú bác giúp em viết code vba thay cho công thức dò tìm và tính
Trả lời
2
Đọc
63
A HOANG 620
A
ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711) (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
12 13 14
Trả lời
262
Đọc
28K
toptikibeauty
T
T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết
    • Cười
Trả lời
3
Đọc
135
minhminh27
minhminh27
nttrung_proneu
Cách giữ công thức khi lọc và tách file
Trả lời
2
Đọc
60
nttrung_proneu
nttrung_proneu
K
  • Question Question
Code vba đọc QR code file hình ảnh trên CCCD
    • Cười
Trả lời
0
Đọc
64
kingbo.camera
K
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024) (1 người xem)
    • Thích
2 3
Trả lời
42
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Gửi mail hàng loạt với mỗi mail là 1 file PDF đính kèm khác nhau
Trả lời
1
Đọc
56
minhminh27
minhminh27
B
Làm sao đổi đơn vị B, M này sang hàng đơn vị vậy mọi người?
    • Cười
Trả lời
4
Đọc
67
Bao Nguyen 89
B
C
Tạo hyperlink hàng loạt
Trả lời
9
Đọc
5K
online.tanphat
O
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA
Trả lời
9
Đọc
7K
SA_DQ
SA_DQ
dongbhhg
Tìm lương cơ sở theo từng tháng
Trả lời
3
Đọc
91
dongbhhg
dongbhhg
V
Làm mẫu giấy đi đường (công lệnh) bằng Excel (1 người xem)
Trả lời
12
Đọc
11K
Gà Công Nghệ
Gà Công Nghệ
N
Thử lập trình XLL add-in bằng C/C++
    • Thích
Trả lời
0
Đọc
91
nguyendang95
N
Tuấn Bụng Bự
tạo QRcode chuyển khoản ngân hàng
Trả lời
5
Đọc
224
Tuấn Bụng Bự
Tuấn Bụng Bự
M
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
1
Đọc
61
BuiQuangThuan
B
Quách Ngọc
Trả về kết quả ngày tháng hay khoảng trống
Trả lời
3
Đọc
70
Quách Ngọc
Quách Ngọc
MaxanB
Cần hỗ trợ công thức Vlookup nhiều sheet theo điều kiên
Trả lời
2
Đọc
93
MaxanB
MaxanB
N
Không chạy được file VBA
Trả lời
3
Đọc
151
nhjngj
N
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
1
Đọc
77
hoangtuaotrang_hp_vn
H
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