Tìm hàng dữ liệu có điều kiện

[sep_hatxel]

GPE ơi! Mong GPE giúp đỡ mình code tìm hàng dữ liệu ở sheet1 thoả mãn điều kiện:Tìm hàng dữ liệu sao cho dữ liệu xuất hiện trong hàng thì xuất hiện ít nhất có từ 2 ô liên tiếp trở lên là thoả mãn và sẽ copy hàng đó paste sang sheet2. Nếu hàng dữ liệu nào mà trường hợp dữ liệu có xuất hiện ở 1 ô nhưng sau đó là ô trống thì loại bỏ không lấy! Mình xin gửi kèm theo file minh hoạ!
- Cảm ơn GPE! Chúc ngày mới thắng lợi!

 

[ndu96081631]

GPE ơi! Mong GPE giúp đỡ mình code tìm hàng dữ liệu ở sheet1 thoả mãn điều kiện:Tìm hàng dữ liệu sao cho dữ liệu xuất hiện trong hàng thì xuất hiện ít nhất có từ 2 ô liên tiếp trở lên là thoả mãn và sẽ copy hàng đó paste sang sheet2. Nếu hàng dữ liệu nào mà trường hợp dữ liệu có xuất hiện ở 1 ô nhưng sau đó là ô trống thì loại bỏ không lấy! Mình xin gửi kèm theo file minh hoạ!
- Cảm ơn GPE! Chúc ngày mới thắng lợi!

Bài này sao hỏi hoài vậy ta?

 

[sep_hatxel]

Bài này sao hỏi hoài vậy ta?

Hì! Không biết nói sao nữa! Bạn giúp mình nhé! Cảm ơn đã quan tâm!

 

[SA_DQ]

Máy của mình cần 1/3 gy

Option Explicit
Dim jJ As Long, lRow As Long, lCol As Byte:              Dim Timer_ As Double
Dim WF As Object, Min_ As Integer, Max_ As Integer, wW As Integer
Dim MyAdd As String:                                    Dim Yes As Boolean

Sub CopyRowsWhen()
 Dim Rng As Range, Sh As Worksheet, RgD As Range, RgC As Range

 Sheet1.Select:                                          Set Sh = Sheet2
 Timer_ = Timer
 lCol = Cells.Find(What:="*", After:=[A1], _
      SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
 lRow = Cells.Find(What:="*", After:=[A1], _
      SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 Sh.[A1].Resize(9 + lRow, lCol + 3).Clear
 [A1].Resize(lRow, 2).Interior.ColorIndex = 0
 For jJ = 4 To lRow
   Set Rng = Cells(jJ, 2 + lCol).End(xlToLeft)
   If Rng.Offset(, -1).Value = "" Then
      Cells(Rng.Row, "A").Interior.ColorIndex = 39
   Else
      Set Rng = Cells(jJ, "A")
      If Rng.Value = "" Then Set Rng = Rng.End(xlToRight)
      If Rng.Offset(, 1).Value = "" Then
         Cells(Rng.Row, "A").Interior.ColorIndex = 38
      Else
         With Sh.Cells(65500, lCol + 2).End(xlUp).Offset(2)
            .Value = jJ
            .Offset(, -lCol - 1).Resize(, lCol).Value = Cells(jJ, 1).Resize(, lCol).Value
         End With
      End If
   End If
 Next jJ
 Application.ScreenUpdating = False:                     Sh.Select
 lRow = Sh.Cells(65500, lCol + 2).End(xlUp).Row
 For jJ = lRow To 2 Step -2
   Set RgD = Cells(jJ, "A")
   If RgD.Value = "" Then Set RgD = RgD.End(xlToRight)
   Set RgC = RgD.End(xlToRight)
   If Range(RgD, RgC).Cells.Count Mod 2 = 1 Then
      RgD.Resize(2).EntireRow.Delete
   Else
      Set RgC = Cells(jJ, lCol)
      If RgC.Value = "" Then Set RgC = RgC.End(xlToLeft)
      Set RgD = RgC.End(xlToLeft)
      If Range(RgD, RgC).Cells.Count Mod 2 = 1 Then
         RgD.Resize(2).EntireRow.Delete
      End If
   End If
 Next jJ
 lRow = Sh.Cells(65500, lCol + 2).End(xlUp).Row
 Set WF = Application.WorksheetFunction
 
 Set RgC = Cells(65500, 1)
 For jJ = lRow To 2 Step -2
   Set Rng = Cells(jJ, "A").Resize(, lCol)
   Min_ = WF.Min(Rng):                                   Max_ = WF.Max(Rng)
   For wW = Min_ To Max_
      Set RgD = Rng.Find(wW, , xlFormulas, xlWhole)
      If Not RgD Is Nothing Then
         MyAdd = RgD.Address
         Do
            If RgD.Offset(, 1).Value = "" And (RgD.Column = 1 Or RgD.Offset(, -1).Value = "") Then
               Set RgC = Union(RgC, RgD.Resize(2))
               Yes = True:                               Exit For
            End If
            Set RgD = Rng.FindNext(RgD)
         Loop While Not RgD Is Nothing And RgD.Address <> MyAdd
      End If
   Next wW
 Next jJ
 RgC.EntireRow.Delete
 MsgBox Timer() - Timer_:                                Set WF = Nothing
End Sub

 

[concogia]

GPE ơi! Mong GPE giúp đỡ mình code tìm hàng dữ liệu ở sheet1 thoả mãn điều kiện:Tìm hàng dữ liệu sao cho dữ liệu xuất hiện trong hàng thì xuất hiện ít nhất có từ 2 ô liên tiếp trở lên là thoả mãn và sẽ copy hàng đó paste sang sheet2. Nếu hàng dữ liệu nào mà trường hợp dữ liệu có xuất hiện ở 1 ô nhưng sau đó là ô trống thì loại bỏ không lấy! Mình xin gửi kèm theo file minh hoạ!
- Cảm ơn GPE! Chúc ngày mới thắng lợi!

Chưa hiểu lắm, mưa buồn, làm đại, bạn chạy thử code này. Mà cái này là cái quái gì vậy, nhìn chóng mặt quá

Public Sub Chuahieulam()
Dim I As Long, J As Long, Mg(1 To 150, 1 To 69), K As Long, M As Long, iA
Sheets("sheet2").[a4:bq500].Clear
M = 1
    For I = 4 To 150
        For J = 2 To 69
            If J = 2 And Cells(I, J - 1) <> "" And Cells(I, J) = "" Then
                iA = 0
                Exit For
            End If
                If J = 69 And Cells(I, J - 1) = "" And Cells(I, J) <> "" Then
                    iA = 0
                    Exit For
                End If
                    If Cells(I, J - 1) = "" And Cells(I, J) <> "" And Cells(I, J + 1) = "" Then
                        iA = 0
                        Exit For
                    End If
        Next
            If iA = "" Then
                For K = 1 To 69
                    Mg(M, K) = Cells(I, K)
                Next
                M = M + 1
           End If
      iA = ""
    Next
 Sheets("sheet2").[a4].Resize(M, 69) = Mg
End Sub

Thân

 

[ChanhTQ@]

Của Cò già chỉ hơn cái ni thôi

Còn thua cái con macro đầu đến 10 lần về thời gian đó các bạn!

Sub CopyAfterFind()
 Dim Rng As Range, sRng As Range, Sh As Worksheet
 
 Sheet1.Select:                                          Set Sh = Sheet2
 Timer_ = Timer()
 lCol = Cells.Find(What:="*", After:=[A1], _
      SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
 lRow = Cells.Find(What:="*", After:=[A1], _
      SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 Sh.[A1].Resize(9 + lRow, lCol + 3).Clear
 Set WF = Application.WorksheetFunction
 For jJ = 4 To lRow
   Set Rng = Cells(jJ, "A").Resize(, lCol)
   Min_ = WF.Min(Rng):                                   Max_ = WF.Max(Rng)
   For wW = Min_ To Max_
      Set sRng = Rng.Find(wW, , xlFormulas, xlWhole)
      If Not sRng Is Nothing Then
         MyAdd = sRng.Address
         Do
            If sRng.Offset(, 1).Value = "" And (sRng.Column = 1 Or sRng.Offset(, -1).Value = "") Then
               Yes = True:                               Exit For
            End If
            Set sRng = Rng.FindNext(sRng)
         Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
      End If
   Next wW
   If Yes Then
      Yes = False
   Else
      With Sh.Cells(65500, lCol + 2).End(xlUp).Offset(2)
         .Value = jJ
         .Offset(, -lCol - 1).Resize(, lCol).Value = Cells(jJ, 1).Resize(, lCol).Value
      End With
   End If
 Next jJ
 MsgBox Timer() - Timer_:                                Set WF = Nothing
End Sub

 

[sep_hatxel]

Vâng! Đúng là như vậy! Cảm ơn các bạn nhiều quá! Chúc các bạn nhiều may mắn! Thân!