Chép dữ liệu từ nhiều cột thành một cột

[thanhhĩen9]

+-+-+-+ Em mới tham gia diễn đàn GPE, Em có vấn đề muốn học hỏi nhờ Thầy cô viết cho em VBA theo yêu cầu trong FILE đính kèm. Cảm ơn Thầy cô.

 

[rollover79]

Em xem rồi nhưng không đúng yêu cầu trong file đính kèm. Cảm ơn

Bạn đã đọc rồi, nhưng nếu không hiểu hoặc không đúng yêu cầu thì bạn phải post lên thì mọi người mới giúp cho bạn được chứ. Bạn cứ im lặng thì đương nhiên mọi người hiểu là bạn đã làm xong rồi. Hơn nữa bạn nói yêu cầu trong file, nhưng khi tôi down file về thì thấy chẳng có yêu cầu gì cả. Có 1 Sheet với mấy vùng dữ liệu thôi, không biết yêu cầu làm gì?

 

[thanhhĩen9]

rollover79

9th Excel Member

Em cảm ơn!


File đính kèm em có commemt ở cells H3

 

[SA_DQ]

Hãy xài macro sau

Option Explicit

Sub Filter2Col()
 Dim lRw As Long, Ff As Long, CopyR As Long
 Dim cRng As Range
 
 lRw = [a65500].End(xlUp).Row:      CopyR = 4
 [i3:j3] = [a3:B3].Value:           Range("I4:J" & lRw).Clear
 
 For Ff = 4 To lRw
   With Cells(Ff, "A")
      If .Offset(, 1) <> "" Then
         If .Offset(, 1) Mod 5 = 0 Then
            Union(cRng, .Resize(, 2)).Copy Destination:=Cells(CopyR, "I")
            CopyR = CopyR + 7:   Set cRng = Nothing
         Else
            If cRng Is Nothing Then
               Set cRng = .Resize(, 2)
            Else
               Set cRng = Union(cRng, .Resize(, 2))
            End If
         End If
      End If
   End With
 Next Ff
 If Not cRng Is Nothing Then
   cRng.Copy Destination:=Cells(CopyR, "I")
   CopyR = CopyR + 7:   Set cRng = Nothing
 End If
 Cells(CopyR, "I") = [a3]:       Cells(CopyR, "J") = [C3]
 CopyR = CopyR + 1
 For Ff = 4 To lRw
   With Cells(Ff, "B")
      If .Offset(, 1) <> "" Then
         If .Offset(, 1) Mod 5 = 0 Then
            Union(cRng, .Offset(, -1), .Offset(, 1)).Copy _
               Destination:=Cells(CopyR, "I")
            CopyR = CopyR + 7:   Set cRng = Nothing
         Else
            If cRng Is Nothing Then
               Set cRng = Union(.Offset(, -1), .Offset(, 1))
            Else
               Set cRng = Union(cRng, .Offset(, -1), .Offset(, 1))
            End If
         End If
      End If
   End With
 Next Ff
 If Not cRng Is Nothing Then
   cRng.Copy Destination:=Cells(CopyR, "I")
   Set cRng = Nothing
 End If

End Sub

 

[rollover79]

http://www.giaiphapexcel.com/forum/member.php?u=85962
Em cảm ơn!
File đính kèm em có commemt ở cells H3

Sao không viết cái yêu cầu ra ngoài mà để trong comment, tôi đọc lướt qua ko thấy gì nên bỏ qua . Vậy bạn tham khảo thêm file này xem sao.