Copy các vùng dữ liệu vào sheet khác

[brachiosaurus]

Chào mọi người!

Mình đang có nhu cầu như sau:
Tại sheet Main
- Copy dữ liệu từ khoảng C18:C63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng I18:I63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng O18:O63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng U18:U63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng AA18:AA63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng AG18:AG63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng AM18:AM63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng AS18:AS63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng AY18:AY63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng BE18:BE63 đến khi hết dữ liệu
Tất cả copy sang sheet Ngay, dữ liệu sau liền tiếp dữ liệu trước, ko có khoảng cách.
Nhưng hiện tại mình bị vướng các vấn đề sau:
- Code chạy hay lỗi, đơ excel phải tắt toàn bộ đi bật lại, nếu ko lỗi code chạy khá nhanh
- Nếu dữ liệu chạy dài từ cột C đến cột H thì đoạn dữ liệu ở khoảng I sẽ bị copy 2 lần

Code của mình như sau:
Private Sub copyluot1()
Sheets("ngay").Select
Dim lastcol As Integer
With ActiveSheet
lastcol = .Cells(6, .Columns.Count).End(xlToLeft).Column
End With
Application.ScreenUpdating = False
Sheets("Main").Select
Range("C18:C63").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Ngay").Select
If Sheets("ngay").Cells(6, 3).Value = "" Then '3 booth
Sheets("Ngay").Select
Range("C6").Select
Selection.End(xlToRight).Select
Range("c6").PasteSpecial xlPasteValues
ElseIf Sheets("ngay").Cells(6, 3).Value <> "" Then '3 booth
Sheets("Ngay").Select
Cells(6, lastcol + 1).PasteSpecial xlPasteValues
End If
Application.CutCopyMode = False
Sheets("Ngay").Select
Range("B5").Select
If Sheets("main").Cells(18, 9) <> "" Then
copyluot2
End If
End Sub

Sau mỗi khoảng lại thêm 1 sub

Mình mới mày mò VBA nên ko biết nhiều, xin mọi ng trợ giúp ạ. Mình cảm ơn

 

[brachiosaurus]

Private Sub copyluot1()
Sheets("ngay").Select
Dim lastcol As Integer
With ActiveSheet
lastcol = .Cells(6, .Columns.Count).End(xlToLeft).Column
End With
Application.ScreenUpdating = False
Sheets("Main").Select
Range("C18:H63").Select
Selection.Copy
Sheets("Ngay").Select
If Sheets("ngay").Cells(6, 3).Value = "" Then '3 booth
Sheets("Ngay").Select
Range("C6").Select
Selection.End(xlToRight).Select
Range("c6").PasteSpecial xlPasteValues
ElseIf Sheets("ngay").Cells(6, 3).Value <> "" Then '3 booth
Sheets("Ngay").Select
Cells(6, lastcol + 1).PasteSpecial xlPasteValues
End If
Application.CutCopyMode = False
Sheets("Ngay").Select
Range("B5").Select
If Sheets("main").Cells(18, 9) <> "" Then
copyluot2
End If
End Sub

Sau 1 hồi dùng não e đã để code như này và ko bị copy trùng nữa nhưng tình trạng đơ vẫn còn, các bác có cao kiến gì giúp e với, hoặc giải thích cho e tại sao nó bị lỗi để có thể phòng và tránh

 

[Ba Tê]

Chào mọi người!

Mình đang có nhu cầu như sau:
Tại sheet Main
- Copy dữ liệu từ khoảng C18:C63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng I18:I63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng O18:O63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng U18:U63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng AA18:AA63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng AG18:AG63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng AM18:AM63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng AS18:AS63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng AY18:AY63 đến khi hết dữ liệu
- Copy dữ liệu từ khoảng BE18:BE63 đến khi hết dữ liệu
Tất cả copy sang sheet Ngay, dữ liệu sau liền tiếp dữ liệu trước, ko có khoảng cách.
Nhưng hiện tại mình bị vướng các vấn đề sau:
- Code chạy hay lỗi, đơ excel phải tắt toàn bộ đi bật lại, nếu ko lỗi code chạy khá nhanh
- Nếu dữ liệu chạy dài từ cột C đến cột H thì đoạn dữ liệu ở khoảng I sẽ bị copy 2 lần

Code của mình như sau:
Private Sub copyluot1()
Sheets("ngay").Select
Dim lastcol As Integer
With ActiveSheet
lastcol = .Cells(6, .Columns.Count).End(xlToLeft).Column
End With
Application.ScreenUpdating = False
Sheets("Main").Select
Range("C18:C63").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Ngay").Select
If Sheets("ngay").Cells(6, 3).Value = "" Then '3 booth
Sheets("Ngay").Select
Range("C6").Select
Selection.End(xlToRight).Select
Range("c6").PasteSpecial xlPasteValues
ElseIf Sheets("ngay").Cells(6, 3).Value <> "" Then '3 booth
Sheets("Ngay").Select
Cells(6, lastcol + 1).PasteSpecial xlPasteValues
End If
Application.CutCopyMode = False
Sheets("Ngay").Select
Range("B5").Select
If Sheets("main").Cells(18, 9) <> "" Then
copyluot2
End If
End Sub

Sau mỗi khoảng lại thêm 1 sub

Mình mới mày mò VBA nên ko biết nhiều, xin mọi ng trợ giúp ạ. Mình cảm ơn

Thà bạn mô tả, giải thích,.... yêu cầu cần làm, kết quả muốn có là gì, chứ đọc code của bạn sao chắc được là hiểu đúng ý bạn.
Tôi đoán mò và viết Sub như vầy để lấy dữ liệu từ Sheet "Main" sang Sheet "Ngay", Nếu bạn xài được thì tốt, còn không thì bỏ qua.
Code này đặt trong Module.

Option Explicit

Public Sub sGpe()
Dim sArr(), dArr(), I As Long, J As Long, R As Long, Col As Long, MaxCoL As Long
With Sheets("Main")
    MaxCoL = .Range("XFD18").End(xlToLeft).Column - 2
    If MaxCoL =0 Then Exit Sub
    sArr = .Range("C18:C63").Resize(, MaxCoL).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To MaxCoL)
End With
For J = 1 To MaxCoL
    If sArr(1, J) <> Empty Then
        Col = Col + 1
        For I = 1 To R
            dArr(I, Col) = sArr(I, J)
        Next I
    End If
Next J
With Sheets("Ngay")
    .Range("C6").Resize(R, 100).ClearContents
    .Range("C6").Resize(R, Col) = dArr
End With
End Sub

 

[brachiosaurus]

Thà bạn mô tả, giải thích,.... yêu cầu cần làm, kết quả muốn có là gì, chứ đọc code của bạn sao chắc được là hiểu đúng ý bạn.
Tôi đoán mò và viết Sub như vầy để lấy dữ liệu từ Sheet "Main" sang Sheet "Ngay", Nếu bạn xài được thì tốt, còn không thì bỏ qua.
Code này đặt trong Module.

Option Explicit

Public Sub sGpe()
Dim sArr(), dArr(), I As Long, J As Long, R As Long, Col As Long, MaxCoL As Long
With Sheets("Main")
    MaxCoL = .Range("XFD18").End(xlToLeft).Column - 2
    If MaxCoL =0 Then Exit Sub
    sArr = .Range("C18:C63").Resize(, MaxCoL).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To MaxCoL)
End With
For J = 1 To MaxCoL
    If sArr(1, J) <> Empty Then
        Col = Col + 1
        For I = 1 To R
            dArr(I, Col) = sArr(I, J)
        Next I
    End If
Next J
With Sheets("Ngay")
    .Range("C6").Resize(R, 100).ClearContents
    .Range("C6").Resize(R, Col) = dArr
End With
End Sub

Rất cảm ơn bạn. Code chạy quá tuyệt vời. Mình lần đầu đặt câu hỏi nên giải thích chưa rõ ràng, lần sau sẽ rút kinh nghiệm. Một lần nữa cảm ơn bạn rất nhiều