Xóa 1 dòng thì List Validation mất tác dụng (1 người xem)

[xucxich]

Mình copy 1 bảng tính xong, chạy code xóa 1 hoặc nhiều dòng, thì các LIST VALIDATION ở ô khác mất tác dụng.
Mình trình bày rõ ở file đính kèm.
Nhờ các bạn giúp cách khắc phục.
Mình cảm ơn!
p/s: Code này mình tận dụng từ các topic ở GPE.

 

[ndu96081631]

Mình copy 1 bảng tính xong, chạy code xóa 1 hoặc nhiều dòng, thì các LIST VALIDATION ở ô khác mất tác dụng.
Mình trình bày rõ ở file đính kèm.
Nhờ các bạn giúp cách khắc phục.
Mình cảm ơn!
p/s: Code này mình tận dụng từ các topic ở GPE.

Validation bị xóa là đúng rồi, vì nó cũng là 1 Shape
Ít nhất phải sửa đoạn này:

For Each Shp In ActiveSheet.Shapes
  For Each rng In sRng.Areas
    If rng.Top <= Shp.Top And Cells(rng.Row + rng.Rows.Count, 1).Top >= Shp.Top Then
      Shp.Delete
    End If
  Next
Next

Thành:

For Each Shp In ActiveSheet.Shapes
  [COLOR=#ff0000]If InStr(Shp.Name, "Drop Down") = 0 Then[/COLOR]
    For Each rng In sRng.Areas
      If rng.Top <= Shp.Top And Cells(rng.Row + rng.Rows.Count, 1).Top >= Shp.Top Then
        Shp.Delete
      End If
    Next
 [COLOR=#ff0000] End If[/COLOR]
Next

Đoạn If màu đỏ thêm vào nhằm mục đích "tránh" thằng Validation ra
------------------
Nói thêm: Code này lượm thượm quá. Chẳng hạn Sub Copy1 và Copy2, đoạn For.. Next chả biết để làm gì

 

[xucxich]

code này mình lấy từ topic nào đó cũng ở trên GPE.
nếu lượm thượm vậy nhờ bạn nào biết về code giúp mình cắt gọt đoạn code cho nó hết lượm thượm.
mình cảm ơn!

 

[ndu96081631]

code này mình lấy từ topic nào đó cũng ở trên GPE.
nếu lượm thượm vậy nhờ bạn nào biết về code giúp mình cắt gọt đoạn code cho nó hết lượm thượm.
mình cảm ơn!

Toàn bộ code có thể là vầy:

Sub copy1()
  Dim i As Long
  i = Range("C65500").End(xlUp).Row + 1
  If i < 5 Then i = 5
  ThisWorkbook.Sheets("copy").Range("A7:D7").Copy Range("A" & i)
End Sub
Sub copy2()
  Dim i As Long
  i = Range("C65500").End(xlUp).Row + 1
  If i < 5 Then i = 5
  ThisWorkbook.Sheets("copy").Range("A8:D8").Copy Range("A" & i)
End Sub
Sub XoaDong()
  Dim rSel As Range, rShp As Range
  Dim shp As Shape
  Dim Anser As Long
  On Error Resume Next
  Set rSel = Selection
  If TypeOf rSel Is Range Then
    Anser = MsgBox("Ban co chac xoa dong da chon khong ?", vbQuestion + vbYesNo, " Are you sure ?")
    If Anser = vbYes Then
      For Each shp In ActiveSheet.Shapes
        If InStr(shp.Name, "Drop Down") = 0 Then
          Set rShp = ShapeRange(shp)
          If Not Intersect(rSel.EntireRow, rShp) Is Nothing Then shp.Delete
        End If
      Next
      rSel.EntireRow.Delete
    End If
  End If
End Sub
Function ShapeRange(ByVal shp As Shape) As Range
  On Error Resume Next
  Set ShapeRange = shp.Parent.Range(shp.TopLeftCell, shp.BottomRightCell)
End Function

Thật ra, nếu bạn dùng Excel 2010 thì tiện hơn rất nhiều: Xóa dòng nào thì các shape trên đó cũng tự động bị xóa theo (không giống như các version trước đó)

 

[xucxich]

Toàn bộ code có thể là vầy:

Sub copy1()
  Dim i As Long
  i = Range("C65500").End(xlUp).Row + 1
  If i < 5 Then i = 5
  ThisWorkbook.Sheets("copy").Range("A7:D7").Copy Range("A" & i)
End Sub
Sub copy2()
  Dim i As Long
  i = Range("C65500").End(xlUp).Row + 1
  If i < 5 Then i = 5
  ThisWorkbook.Sheets("copy").Range("A8:D8").Copy Range("A" & i)
End Sub
Sub XoaDong()
  Dim rSel As Range, rShp As Range
  Dim shp As Shape
  Dim Anser As Long
  On Error Resume Next
  Set rSel = Selection
  If TypeOf rSel Is Range Then
    Anser = MsgBox("Ban co chac xoa dong da chon khong ?", vbQuestion + vbYesNo, " Are you sure ?")
    If Anser = vbYes Then
      For Each shp In ActiveSheet.Shapes
        If InStr(shp.Name, "Drop Down") = 0 Then
          Set rShp = ShapeRange(shp)
          If Not Intersect(rSel.EntireRow, rShp) Is Nothing Then shp.Delete
        End If
      Next
      rSel.EntireRow.Delete
    End If
  End If
End Sub
Function ShapeRange(ByVal shp As Shape) As Range
  On Error Resume Next
  Set ShapeRange = shp.Parent.Range(shp.TopLeftCell, shp.BottomRightCell)
End Function

Thật ra, nếu bạn dùng Excel 2010 thì tiện hơn rất nhiều: Xóa dòng nào thì các shape trên đó cũng tự động bị xóa theo (không giống như các version trước đó)

Code a chỉnh lại gọn gàng và dễ học hơn, nhất là đoạn copy
nhưng code copy còn thiếu 1 điều kiện a ah, nếu ở giữa có 1 dòng trống thì nó phải copy chèn vào dòng trống đó (áp dụng cho trường hợp người dùng cần chèn thêm dòng ở giữa bảng)
như file đính kèm là dòng thứ 6, nếu e chạy code copy tiếp thì nó copy và paste vào dòng thứ 9 chứ ko phải dòng thứ 6.

 

[ndu96081631]

Code a chỉnh lại gọn gàng và dễ học hơn, nhất là đoạn copy
nhưng code copy còn thiếu 1 điều kiện a ah, nếu ở giữa có 1 dòng trống thì nó phải copy chèn vào dòng trống đó (áp dụng cho trường hợp người dùng cần chèn thêm dòng ở giữa bảng)
như file đính kèm là dòng thứ 6, nếu e chạy code copy tiếp thì nó copy và paste vào dòng thứ 9 chứ ko phải dòng thứ 6.

Cũng dễ thôi
Code sửa thành:

Sub copy1()
  Dim Rng As Range
  With Range("B5").CurrentRegion
    If .Count = 1 And .Cells(1, 1) = "" Then
      Set Rng = Range("A5")
    Else
      Set Rng = .Offset(.Rows.Count).Resize(1, 1)
    End If
  End With
  ThisWorkbook.Sheets("copy").Range("A7:D7").Copy Rng.Offset(, -1)
End Sub
Sub copy2()
  Dim Rng As Range
  With Range("B5").CurrentRegion
    If .Count = 1 And .Cells(1, 1) = "" Then
      Set Rng = Range("B5")
    Else
      Set Rng = .Offset(.Rows.Count).Resize(1, 1)
    End If
  End With
  ThisWorkbook.Sheets("copy").Range("A8:D8").Copy Rng.Offset(, -1)
End Sub

Tuy nhiên, ta thấy rằng Sub Copy1 và Copy2 có cấu trúc y chang nhau nên có thể gộp chung lại thành:

Sub copy1()
  CopyRange ThisWorkbook.Sheets("copy").Range("A7:D7")
End Sub
Sub copy2()
  CopyRange ThisWorkbook.Sheets("copy").Range("A8:D8")
End Sub
Sub CopyRange(ByVal SourceRng As Range)
  Dim Rng As Range
  With Range("B5").CurrentRegion
    If .Count = 1 And .Cells(1, 1) = "" Then
      Set Rng = Range("B5")
    Else
      Set Rng = .Offset(.Rows.Count).Resize(1, 1)
    End If
  End With
  SourceRng.Copy Rng.Offset(, -1)
End Sub

Bạn thử xem

 

[xucxich]

Tuy nhiên, ta thấy rằng Sub Copy1 và Copy2 có cấu trúc y chang nhau nên có thể gộp chung lại thành:

Sub copy1()
  CopyRange ThisWorkbook.Sheets("copy").Range("A7:D7")
End Sub
Sub copy2()
  CopyRange ThisWorkbook.Sheets("copy").Range("A8:D8")
End Sub
Sub CopyRange(ByVal SourceRng As Range)
  Dim Rng As Range
  With Range("B5").CurrentRegion
    If .Count = 1 And .Cells(1, 1) = "" Then
      Set Rng = Range("B5")
    Else
      Set Rng = .Offset(.Rows.Count).Resize(1, 1)
    End If
  End With
  SourceRng.Copy Rng.Offset(, -1)
End Sub

Bạn thử xem

may mắn gặp đúng cao chỉ bảo rồi
code này áp dụng cho nhiều vùng copy mà có cấu trúc giống nhau thì đúng là gọn gàng hết cỡ. quá lợi hại.
cảm ơn a lần nữa!

 

[xucxich]

em có câu hỏi này:
nếu ở cột A bên sheet copy e thêm bất kỳ ký tự nào (ví dụ ở đây e thêm TT)
thì khi copy dòng thứ 2 xảy ra lỗi.
em đã thử thay đổi

[COLOR=#000000][I]SourceRng.Copy Rng.Offset(, -1)[/I][/COLOR]

thành

[COLOR=#000000][I]SourceRng.Copy Rng.Offset(, 0)[/I][/COLOR]

thì thấy copy bình thường, nhưng vị trí paste lại bắt đầu từ cột B.
e lại tiếp tục mò mẫm thay đổi các con số khác nhưng càng làm càng tệ
nhờ anh nào xem giúp.
- với lại e muốn thêm cái dòng code bên dưới vào trong đoạn code copy mà ko biết nên cho nó vào vị trí nào, nhờ các anh giúp luôn.

Range("A" & i).RowHeight = 27

đoạn code trên đại khái là e muốn khi copy nó tự hiệu chỉnh chiều cao dòng =27px

 

[ndu96081631]

em có câu hỏi này:
nếu ở cột A bên sheet copy e thêm bất kỳ ký tự nào (ví dụ ở đây e thêm TT)
thì khi copy dòng thứ 2 xảy ra lỗi.
em đã thử thay đổi

[COLOR=#000000][I]SourceRng.Copy Rng.Offset(, -1)[/I][/COLOR]

thành

[COLOR=#000000][I]SourceRng.Copy Rng.Offset(, 0)[/I][/COLOR]

thì thấy copy bình thường, nhưng vị trí paste lại bắt đầu từ cột B.
e lại tiếp tục mò mẫm thay đổi các con số khác nhưng càng làm càng tệ
nhờ anh nào xem giúp.

Bởi vậy bạn rút kinh nghiệm: Dữ liệu nên THẬT ngay từ đầu (có cái gì cứ cho vào cho đúng thực tể)
Nếu dữ liệu có luôn ở cột A lại càng dễ:

Sub CopyRange(ByVal SourceRng As Range)
  Dim Rng As Range
  With Range("[COLOR=#ff0000]A5[/COLOR]").CurrentRegion
    If .Count = 1 And .Cells(1, 1) = "" Then
      Set Rng = Range("[COLOR=#ff0000]A5[/COLOR]")
    Else
      Set Rng = .Offset(.Rows.Count).Resize(1, 1)
    End If
  End With
  SourceRng.Copy [COLOR=#ff0000]Rng[/COLOR]
End Sub

Những chổ màu đỏ là những chổ phải sửa lai

- với lại e muốn thêm cái dòng code bên dưới vào trong đoạn code copy mà ko biết nên cho nó vào vị trí nào, nhờ các anh giúp luôn.

Range("A" & i).RowHeight = 27

đoạn code trên đại khái là e muốn khi copy nó tự hiệu chỉnh chiều cao dòng =27px

Có lẽ bạn muốn vầy chăng:

Sub CopyRange(ByVal SourceRng As Range)
  Dim Rng As Range
  With Range("A5").CurrentRegion
    If .Count = 1 And .Cells(1, 1) = "" Then
      Set Rng = Range("A5")
    Else
      Set Rng = .Offset(.Rows.Count).Resize(1, 1)
    End If
  End With
  SourceRng.Copy Rng
  [COLOR=#ff0000]Rng.RowHeight = 27[/COLOR]
End Sub

 

[xucxich]

ko phải là e muốn dấu dữ liệu đâu a, mà vì cái dữ liệu ở cột A lúc có lúc không, tùy thuộc vào đối tượng mình đưa vào.
Em áp dụng cái điều kiện ko xóa Validation cho đoạn code xóa toàn bộ bảng (chứ ko phải xóa từng dòng) rồi copy và paste lại bảng mới để tránh tình trạng cái Validation cũng mất luôn.
a xem đoạn code như vậy được ko?

Sub xoatoanbo()
On Error Resume Next
Anser = MsgBox("Ban co chac xoa toan bo de thong ke lai khong ?", vbQuestion + vbYesNo, " Are you sure ?")
If Anser = vbYes Then
Dim Sh As Shape
For Each Sh In ActiveSheet.Shapes
[COLOR=#ff0000]    If InStr(shp.Name, "Drop Down") = 0 Then[/COLOR]
        If Sh.BottomRightCell.Column <= 4 Then
        If Sh.BottomRightCell.Row <= 500 Then
        If Sh.BottomRightCell.Row >= 5 Then
            Sh.Delete
        End If: End If: End If
        Next
            Range("A5:D500").UnMerge
            Range("A5:D500").Clear
[COLOR=#0000cd]        If [C7].Value <> "" Then[/COLOR]
[COLOR=#0000cd]            Range([C6], [C6].End(xlDown)).Select[/COLOR]
[COLOR=#0000cd]            Else: Range("C5:C6").Select[/COLOR]
[COLOR=#0000cd]        End If[/COLOR]
        Selection.Clear
        [C5].Select
[COLOR=#ff0000]    End If[/COLOR]
End If
End Sub

Cái dòng màu đỏ là đoạn code của a, còn cái dòng màu xanh e ko biết nó có tác dụng gì ko nữa (cũng là code e lượm được) hi

 

[xucxich]

Vấn đề này của e cũng liên quan đến Validation nên e ko tạo topic mới vì sợ các mod nói e spam.
Nhờ các Thầy hoặc các a nào biết giúp e vụ xóa bảng này với. có lẽ câu hỏi của e ko được rõ nên không thấy thầy nào giúp, giờ e gửi thêm cái file đính kèm các thầy xem sẽ rõ hơn.
Mong các thầy giúp e
Trân trọng!