Gộp Nhiều cột của sheet sang 1 cột của sheet khác

[Hieu_Vinh]

Dears các Anh Chị Em.
Giúp Mình với. Có nhiều cột của 1 sheet.
Yêu cầu, copy liên tục những cột đó sang 1 cột duy nhất sang sheet khác bằng Code VBA

 

[Ronaldinho7]

Dears các Anh Chị Em.
Giúp Mình với. Có nhiều cột của 1 sheet.
Yêu cầu, copy liên tục những cột đó sang 1 cột duy nhất sang sheet khác bằng Code VBA

View attachment 289029

Bạn thử thực hiện recode macro rồi chỉnh sửa code xem được không?

 

[Quang_Hải]

Dears các Anh Chị Em.
Giúp Mình với. Có nhiều cột của 1 sheet.
Yêu cầu, copy liên tục những cột đó sang 1 cột duy nhất sang sheet khác bằng Code VBA

View attachment 289029

Thử code này coi sao

Sub Copyyy()
Dim sArr(), j As Long, i As Long, dArr(), k As Long
With Sheets("Copy Sheet")
   sArr = .Range("A1").CurrentRegion.Value
End With
ReDim dArr(1 To UBound(sArr) * UBound(sArr, 2), 1 To 1)
For j = 1 To UBound(sArr, 2)
   For i = 2 To UBound(sArr)
      If sArr(i, j) <> Empty Then
         k = k + 1
         dArr(k, 1) = sArr(i, j)
      End If
   Next
Next
If k Then Sheets("Phu Luc").Range("B10").Resize(k) = dArr
End Sub

 

[Hieu_Vinh]

Sub Copyyy() Dim sArr(), j As Long, i As Long, dArr(), k As Long With Sheets("Copy Sheet") sArr = .Range("A1").CurrentRegion.Value End With ReDim dArr(1 To UBound(sArr) * UBound(sArr, 2), 1 To 1) For j = 1 To UBound(sArr, 2) For i = 2 To UBound(sArr) If sArr(i, j) <> Empty Then k = k + 1 dArr(k, 1) = sArr(i, j) End If Next Next If k Then Sheets("Phu Luc").Range("B10").Resize(k) = dArr End Sub

Dear Anh,
Code hoạt động cực tốt. Xin cảm ơn anh cùng mọi người ạ.
Chúc anh cùng gia đình ngày cuối tuần vui vẻ, hạnh phúc

 

[Lê Duy Thương]

Thử code này coi sao

Sub Copyyy()
Dim sArr(), j As Long, i As Long, dArr(), k As Long
With Sheets("Copy Sheet")
   sArr = .Range("A1").CurrentRegion.Value
End With
ReDim dArr(1 To UBound(sArr) * UBound(sArr, 2), 1 To 1)
For j = 1 To UBound(sArr, 2)
   For i = 2 To UBound(sArr)
      If sArr(i, j) <> Empty Then
         k = k + 1
         dArr(k, 1) = sArr(i, j)
      End If
   Next
Next
If k Then Sheets("Phu Luc").Range("B10").Resize(k) = dArr
End Sub

nếu office 365 thì vầy anh hải ơi
=TOCOL('COPY SHEET'!$A$2:$K$51,3)

 

[barney1]

Dear Anh,
Code hoạt động cực tốt. Xin cảm ơn anh cùng mọi người ạ.
Chúc anh cùng gia đình ngày cuối tuần vui vẻ, hạnh phúc

Định dạng số sau khi copy chưa đúng mà