Tự động tham chiếu dò tìm có điệu kiện bút toán điều chỉnh tự động. (7 người xem)

[immanuel]

Mình có một bảng danh sách các bút toán điều chỉnh và không điều chỉnh. Trong đó khi mình chọn điều kiện cột F: (Y/N), nếu chọn N thì bút toán đó không điều chỉnh và được tham chiếu tự động xuống dòng khác của bảng tính. Bình thường thì mình làm rất thủ công. Các bạn xem giúp mình có cách nào mà tham chiếu tự động không.
Mình gửi File đính kèm. Rất mong các bạn chỉ giáo giúp mình.
Xin cám ơn các bạn.

 

[satthuvae]

Cái này chắc phải đợi các cao thủ marco mới giúp được bạn

 

[sealand]

Kiểu hỏi nửa vời thế này còn khó hơn đánh đố!!!

 

[immanuel]

@ Sealand. Anh xem lại File đính kèm giúp em với.
Có marco nào tự động không ah. Em cám ơn ah.

 

[sealand]

Có thể dùng code sau

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, j
If Not Intersect(Target, [F5:F14]) Is Nothing Then
j = 20
[A20:F28].ClearContents
For i = 5 To 14
If UCase(Cells(i, "F")) = "N" Then
Cells(i, "A").Resize(, 6).Copy Cells(j, "A")
Cells(j, "A") = j - 19
j = j + 1
End If
Next
End If
End Sub

 

[immanuel]

Òa, em cám ơn anh ah. Like anh. Thật tuyệt ah.

 

[immanuel]

Anh ơi, cho em hỏi, em có một thắc mắc nhỏ, khi mà em chèn thêm một dòng ở bảng nhập đó thì báo lỗi ở maro. Vì bảng nhập này có khả năng khi phát sinh nhiều bút toán em phải chèn thêm nhiều dòng. Anh xem giúp em có cách nào không ah.
Em cám ơn anh!

 

[comet_1701]

Có thể dùng code sau

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, j
If Not Intersect(Target, [F5:F14]) Is Nothing Then
j = 20
[A20:F28].ClearContents
For i = 5 To 14
If UCase(Cells(i, "F")) = "N" Then
Cells(i, "A").Resize(, 6).Copy Cells(j, "A")
Cells(j, "A") = j - 19
j = j + 1
End If
Next
End If
End Sub

Cells(j, "A") = j - 19
j = j + 1

Đoạn này nhìn có vẻ đơn giản nhưng nguy hiểm quá. anh Việt dùng sự kiện change hợp lý quá

 

[immanuel]

Vậy xử lý việc chèn dòng này, Các anh xem giúp em phải xử lý thế nào ah.

 

[immanuel]

Anh Sealand giúp em với, trong trường hợp của em nó chèn thêm dòng thì marco báo lỗi, làm cách nào khắc phục được yếu tố này khi tự động thêm dòng.

 

[sealand]

Bạn chép thế Code này vào xem sao:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, j, x
If Not Intersect(Target, [F5:F14]) Is Nothing Then
j = Range([A65536], [A5]).Find("STT").Offset(1).Row
Range([A65536], Cells(j, "F")).ClearContents
x = j
For i = 5 To j - 1
If UCase(Cells(i, "F")) = "N" Then
Cells(i, "A").Resize(, 6).Copy Cells(j, "A")
Cells(j, "A") = j - x + 1
j = j + 1
End If
Next
End If
End Sub

 

[immanuel]

Em cám ơn anh nhiều nhé.

 

[immanuel]

Anh ơi, cái marco này thật hiệu quá, nhưng so với các lệch marco khác thì sao mỗi khi em thực hiện lệch chọn Y/N thì nó quay và chạy một lúc mới thao tác được. Anh xem có cách nào khắc phục được ngược điểm này không ah.
Em cám ơn.

 

[sealand]

Nếu máy yếu dùng code sau sẽ hiệu quả hơn

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, j, x, y, Tm, Kq()
If Not Intersect(Target, [F5:F14]) Is Nothing Then
Application.ScreenUpdating = False
j = Range([A65536], [A5]).Find("STT").Offset(1).Row
If j < 6 Then Exit Sub
Range([A65536].End(3), Cells(j, "F")).ClearContents
ReDim Kq(1 To j - 5, 1 To 6)
Tm = Range(Cells(5, 1), Cells(j - 1, 6))
For i = 1 To UBound(Tm, 1)
If UCase(Tm(i, 6)) = "N" Then
x = x + 1
For y = 2 To 6
Kq(x, 1) = x
Kq(x, y) = Tm(i, y)
Next
End If
Next
Cells(j, 1).Resize(x, 6) = Kq
End If
End Sub

 

[immanuel]

Em cám ơi anh Sealand sự chỉ bảo nhiệt tình ạ.

 

[immanuel]

Anh Sealand ơi, anh giúp em xử lý vụ tạo cột tự động mà chỉ cần nhập số lượng sẽ ra số lượng cột giống cột bên cạnh không. Em gửi mail cho các anh cao thủ nhưng vẫn chưa được, anh xem giúp em.
Cám ơn anh.