Dùng code để copy từ nhiều sheet sang 1 sheet

Liên hệ QC
Lê Duy Thương

Lê Duy Thương

Cạo lấy gì gội (Dịch quá không gội được)
Tham gia
14/10/09
Bài viết
3,111
Được thích
4,846
Kính gửi các anh chị em
tôi đang gặp vấn đề về code
do vậy nhờ các cao thủ giúp cho
chi tiết yêu cầu trong file đính kèm
trân trọng
mời các bạn xem bài #4 nhé
 
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Le duy Thuong đã viết:
Kính gửi các anh chị em
tôi đang gặp vấn đề về code
do vậy nhờ các cao thủ giúp cho
chi tiết yêu cầu trong file đính kèm
trân trọng
Nhấp chuột vào đây để mở rộng...
Sao bạn không đưa ví dụ chỉ 2 sh và vài dòng. Và nhất là tiêu chí chép. Nhìn vào Sh Print ở mấy dòng đầu chưa tìm ra tiêu chí nào liên quan với sh 1.
Cám ơn.
 
Upvote 0
ThuNghi đã viết:
Sao bạn không đưa ví dụ chỉ 2 sh và vài dòng. Và nhất là tiêu chí chép. Nhìn vào Sh Print ở mấy dòng đầu chưa tìm ra tiêu chí nào liên quan với sh 1.
Cám ơn.
Nhấp chuột vào đây để mở rộng...
gui bác thu nghi+bác chanh TQ
xin lỗi mọi người vì em giải thích không rõ ràng
copy value Range("A2:J62") của từng sheet sang sheet print
ví dụ sh 1=("A2:J62")===replace vào a1:a61 cua print
2=("A2:J62")=== replace vào a2:a123 của print
và cứ thế nối cho đến khi hết 31 sheet
sau đó từ đông xóa cột b của sheet print
chọn autofiter và sort từ a--z của cột b sheet print . save
trong file đính kèm đã có dữ liệu từ 1---23 rồi các bác ơi
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Mình không mở được file của bạn nhưng theo bạn mô tả có phải bạn dồn thành 1 cột không, số ô không bằng nhau thì chép ra sao?
Còn cái vụ chép/in thì có lẽ không có vấn đề gì. Miễn là hiểu được.
 
Upvote 0
sealand đã viết:
Mình không mở được file của bạn nhưng theo bạn mô tả có phải bạn dồn thành 1 cột không, số ô không bằng nhau thì chép ra sao?
Còn cái vụ chép/in thì có lẽ không có vấn đề gì. Miễn là hiểu được.
Nhấp chuột vào đây để mở rộng...
em đã chuyển thành ex2003 rồi bác lấy xuống và giúp em nhé
 
Upvote 0
Mình không hiểu:
1/Chép tiêu đề sang để làm gì?
2/Các Line không có nội dung trong các cột khác để hay xóa?
 
Upvote 0
sealand đã viết:
Mình không hiểu:
1/Chép tiêu đề sang để làm gì?--để làm ranh giới của từng sheet thôi
2/Các Line không có nội dung trong các cột khác để hay xóa?--xóa luôn càng tốt
nếu các rows nào rỗng thì delete luông càng tốt/QUOTE]
tiêu đề sau khi sort thì sẽ nằm dưới cùng rồi bác ạ
Nhấp chuột vào đây để mở rộng...
 
Lần chỉnh sửa cuối:
Upvote 0
Gần xong, nhưng nghir xem bóng đá đã. Muộn hoặc sớm mai gửi bài nha
 
Upvote 0
Le duy Thuong đã viết:
sealand đã viết:
Mình không hiểu:
1/Chép tiêu đề sang để làm gì?--để làm ranh giới của từng sheet thôi
2/Các Line không có nội dung trong các cột khác để hay xóa?--xóa luôn càng tốt
nếu các rows nào rỗng thì delete luông càng tốt/QUOTE]
tiêu đề sau khi sort thì sẽ nằm dưới cùng rồi bác ạ
Nhấp chuột vào đây để mở rộng...
1/Chép tiêu đề sang để làm gì?--để làm ranh giới của từng sheet thôi ==> Làm quái gì thấy được nó nữa mà làm ranh với chả giới
Dữ liệu kinh khủng (toàn cái chi chi, chẳng có Ken, Tiger.. gì cả) quá chẳng "kiểm cha kiểm chú" gì được, bạn kiểm nhé
tiêu đề sau khi sort thì sẽ nằm dưới cùng rồi bác ạ==> nằm ở gần cuối thôi, "trông thấy ghét", mình chả chép nó qua đâu
Mình tạo thêm sheet "ttt" cho chạy dữ liệu vào đó để so sánh với sheet print nhé bạn, chú ý trừ những dòng chứa tiêu đề ra nhé
Thân
Mã: 
Private Sub CommandButton1_Click()
    Dim Vung As Range, i As Integer, K As Long, J As Long
        Sheets("ttt").Range("a2:j5000").Clear
            For i = 1 To 31
                K = 1 + (60 * (i - 1))
                Set Vung = Sheets("" & i).Range("a3:j62")
                    Vung.Copy Sheets("ttt").Range("a" & K + 1)
            Next
                    With Sheets("ttt")
                        .[b1:i1].Cut .[c1]
                        .Columns("B:B").Delete Shift:=xlToLeft
                    End With
        With Sheets("ttt").Range("a2:a" & K + 60).Resize(, 9)
            .MergeCells = False
            .Sort Sheets("ttt").[b2], 1
        End With
    With Sheets("ttt")
        J = .[b10000].End(xlUp).Row + 1
        .Range(Sheets("ttt").Rows(J), Sheets("ttt").Rows(10000)).Delete
    End With
End Sub
Trúng thì tốt, trật thì thôi, bài này làm đau đầu quá, "hông" làm nữa đâu
Nhấp chuột vào đây để mở rộng...
 

File đính kèm

Upvote 0
Duy Thuong Kiểm tra giùm nha (Mình thêm cột tên Sheet để tiện kiểm tra, xếp, lọc)

Mã: 
Option Explicit
Sub CopyDT()
Dim j, i, cl As Range, Rg As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Pr.[a2:J65536].Clear
For j = 1 To 31
Set cl = Pr.[a65536].End(xlUp).Offset(1)
i = Trim(Str(j))
Worksheets(i).Range("B3:J62").Copy cl
cl.Resize(59, 9).UnMerge
For i = 2 To 61
cl.Offset(, 9) = Str(j)
If cl = "" Then cl = cl.Offset(-1)
Set cl = cl.Offset(1)
Next
Next
With Pr
.Range("A1:J" & Pr.[a65536].End(xlUp).Row).AutoFilter Field:=2, Criteria1:="="
.AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows. _
                   Count - 1).SpecialCells(xlCellTypeVisible).Delete
.Range("A1:J" & Pr.[a65536].End(xlUp).Row).AutoFilter
.Cells.ClearFormats
.Columns("A:I").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End With
Application.ScreenUpdating = True
End Sub
 

File đính kèm

Upvote 0
sealand đã viết:
duy thuong kiểm tra giùm nha (mình thêm cột tên sheet để tiện kiểm tra, xếp, lọc)

Mã: 
option explicit
sub copydt()
dim j, i, cl as range, rg as range
application.displayalerts = false
application.screenupdating = false
pr.[a2:j65536].clear
for j = 1 to 31
set cl = pr.[a65536].end(xlup).offset(1)
i = trim(str(j))
worksheets(i).range("b3:j62").copy cl
cl.resize(59, 9).unmerge
for i = 2 to 61
cl.offset(, 9) = str(j)
if cl = "" then cl = cl.offset(-1)
set cl = cl.offset(1)
next
next
with pr
.range("a1:j" & pr.[a65536].end(xlup).row).autofilter field:=2, criteria1:="="
.autofilter.range.offset(1, 0).resize(.autofilter.range.rows. _
count - 1).specialcells(xlcelltypevisible).delete
.range("a1:j" & pr.[a65536].end(xlup).row).autofilter
.cells.clearformats
.columns("a:i").sort key1:=range("b2"), order1:=xlascending, header:=xlguess, _
ordercustom:=1, matchcase:=false, orientation:=xltoptobottom, _
dataoption1:=xlsortnormal
end with
application.screenupdating = true
end sub
Nhấp chuột vào đây để mở rộng...

em muốn gán code vào "com..button" bên sheet data chứ không phải bên sheet print
khi em move cái code cua bác sang nút bên sheet data thì nó không chạy
 
Upvote 0
Thuong sua 1 chút là duoc thôi mà
 

File đính kèm

Upvote 0
sealand đã viết:
Thuong sua 1 chút là duoc thôi mà
Nhấp chuột vào đây để mở rộng...
CÓ 3 CODE
CHẠY CHO KẾT QUẢ GIỐNG NHAU .ĐỀU CÓ NHỮNG ĐIỂM KHÁC NHAU
Mã: 
Private Sub CommandButton3_Click()
Sheets("print").Select
ActiveSheet.Cells.Delete Shift:=xlUp
ActiveSheet.Range("A1").Select
For i = 1 To 31
shname = Trim(Str(i))
Sheets(shname).Select
ActiveSheet.Range("A2:J62").Copy
Sheets("print").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ActiveSheet.Range("A" & i * 60 + 1).Select
Next
Sheets("print").Select
ActiveSheet.Range("b:b").Delete Shift:=xlUp
ActiveSheet.Range("A1:i1892").AutoFilter
ActiveSheet.Range("A1").FormulaR1C1 = "Lines"
ActiveWorkbook.Worksheets("print").AutoFilter.Sort.SortFields.Add Key:=Range( _
"B1:B1892"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("print").AutoFilter.Sort
.Header = xlYes
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
ActiveWorkbook.Save
End With
End Sub
CODE NÀY CHẠY CHẬM HƠN NHƯNG KẾT QUẢ NHƯ Ý NHẤT( ???)
.......................................................................................................
Mã: 
Option Explicit
Sub CopyDT()
Dim j, i, cl As Range, Rg As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False
pr.[a2:J65536].Clear
For j = 1 To 31
Set cl = pr.[a65536].End(xlUp).Offset(1)
i = Trim(Str(j))
Worksheets(i).Range("B3:J62").Copy cl
cl.Resize(59, 9).UnMerge
For i = 2 To 61
cl.Offset(, 9) = Str(j)
If cl = "" Then cl = cl.Offset(-1)
Set cl = cl.Offset(1)
Next
Next
With pr
.Select
.Range("A1:J" & pr.[a65536].End(xlUp).Row).AutoFilter Field:=2, Criteria1:="="
.AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows. _
Count - 1).SpecialCells(xlCellTypeVisible).Delete
.Range("A1:J" & pr.[a65536].End(xlUp).Row).AutoFilter
.Cells.ClearFormats
.Columns("A:I").Sort Key1:=Range("B1"), Order1:=xlAscending
End With
Sheet36.Select
Application.ScreenUpdating = True
End Sub
CODE NÀY CHẠY NHANH HƠN CHÚT NHƯNG PHẢI CHÉP TIÊU ĐỀ TRƯỚC(BÁC SEALAND)
................................................................................................
Mã: 
Private Sub CommandButton1_Click()
Dim Vung As Range, i As Integer, K As Long, j As Long
Sheets("print").Range("a2:j5000").Clear
For i = 1 To 31
K = 1 + (60 * (i - 1))
Set Vung = Sheets("" & i).Range("a3:j62")
Vung.Copy Sheets("print").Range("a" & K + 1)
Next
With Sheets("print")
.[b1:i1].Cut .[c1]
.Columns("B:B").Delete Shift:=xlToLeft
End With
With Sheets("print").Range("a2:a" & K + 60).Resize(, 9)
.MergeCells = False
.Sort Sheets("print").[b2], 1
End With
With Sheets("print")
j = .[b10000].End(xlUp).Row + 1
.Range(Sheets("print").Rows(j), Sheets("print").Rows(10000)).Delete
End With
End Sub
CODE NÀY CHẠY NHANH NHẤT NHƯNG KHÔNG CÓ TIÊU ĐỀ . CŨNG CẦN PHẢI CHÉP TIÊU ĐỀ TRƯỚC(BÁC CONCOGIA)
cái code này nếu dữ liệu gốc có công thức thì không ổn bác cò già ơi
NÓI CHUNG CẢ 3 ĐỀU CHO KẾT QUẢ NHƯ EM MONG MUỐN TUY MỖI NGƯỜI CÓ MỖI CÁCH KHÁC NHAU
 
Lần chỉnh sửa cuối:
Upvote 0
Code này khác 3 code trên: Không dùng phương thức copy. Nhanh gấp đôi code sealand.

Mã: 
Sub copyptm()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

With Pr
    .Cells.Clear
    .[A1].Resize(1, 10).Value = Sheets("1").[a2].Resize(1, 10).Value

    For i = 1 To 31
        endr = 2 + (i - 1) * 60
        Shname = Trim(Str(i))
        .Range("A" & endr & ":J" & endr + 59).Value = Sheets(Shname).[a3].Resize(60, 10).Value
    Next
    .Columns("b:b").Delete: .[A1] = "Line"
    .Select
    .Range("A1:J" & endr + 60).Select
    With Selection
        .AutoFilter Field:=2, Criteria1:="="
        .Offset(1).Delete Shift:=xlUp
        .AutoFilter
        .Sort Key1:=.Range("B1"), Order1:=xlAscending, Header:=xlYes
    End With
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
ptm0412 đã viết:
Code này khác 3 code trên: Không dùng phương thức copy. Nhanh gấp đôi code sealand.

Mã: 
Sub copyptm()
Application.DisplayAlerts = False
Application.ScreenUpdating = False

With Pr
    .Cells.Clear
    .[A1].Resize(1, 10).Value = Sheets("1").[a2].Resize(1, 10).Value

    For i = 1 To 31
        endr = 2 + (i - 1) * 60
        Shname = Trim(Str(i))
        .Range("A" & endr & ":J" & endr + 59).Value = Sheets(Shname).[a3].Resize(60, 10).Value
    Next
    .Columns("b:b").Delete: .[A1] = "Line"
    .Select
    .Range("A1:J" & endr + 60).Select
    With Selection
        .AutoFilter Field:=2, Criteria1:="="
        .Offset(1).Delete Shift:=xlUp
        .AutoFilter
        .Sort Key1:=.Range("B1"), Order1:=xlAscending, Header:=xlYes
    End With
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
Nhấp chuột vào đây để mở rộng...
Em dùng array thì tốc độ nhanh lắm nhưng mà có điều chưa hiểu, nếu i > 24 ie lấy dữ liệu của sh > 24 thì nó không chạy mà báo lỗi. Chỉ cho lấy đến 24.
Nhấp chuột vào đây để mở rộng...
em tìm ra nguyên nhân, do sh 25 rỗng => s=0
Code như sau:
PHP: 
Sub copyTN()
Dim s As Long, i As Integer, j As Long, k As Long, endR As Long
Dim T, shName As String, myRng As Range
T = Timer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Arr(), ArrKQ(1 To 30, 1 To 10)
With Pr
  .Cells.Clear
  .[A1].Resize(1, 10).Value = Sheets("1").[a2].Resize(1, 10).Value
  endR = 2
  For i = 1 To 31
    s = 0: shName = CStr(i)
    With Sheets(shName)
      Arr = .[a3].Resize(60, 10).Value
      For j = 1 To 60
        If Len(Arr(j, 1)) > 0 Then
          If Len(Arr(j, 3)) > 0 Then
            s = s + 1
            For k = 1 To 10
              ArrKQ(s, k) = Arr(j, k)
            Next k
          End If
        End If
      Next j
    End With
    If s = 0 Then GoTo bien
    .Range("A" & endR).Resize(s, 10) = ArrKQ
    endR = endR + s
bien:
  Next i
Set myRng = .[a2].Resize(endR - 2, 10)
With myRng
  .Sort Key1:=myRng.Cells(1, 3), Order1:=xlAscending, Header:=xlNo
End With
End With
Set myRng = Nothing
Erase Arr, ArrKQ
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox Timer - T
End Sub
Cám ơn nhiều.
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

T
  • Question Question
Xin code VBA trả về tên tài khoản theo điều kiện
    • Chấp nhận
Trả lời
12
Đọc
393
VetMini
V
mucongnghenhat
lỗi đoạn văn bản bị đóng khung
Trả lời
0
Đọc
27
mucongnghenhat
mucongnghenhat
HeSanbi
  • Question Question
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
8
Đọc
588
nguyendang95
N
Uyên dương Hoya
Lỗi định dạng form chữ trong excel
Trả lời
1
Đọc
58
DeTong
D
ntnguyentam1907
Lấy bảng dữ liệu chứng khoán về excel
2
Trả lời
22
Đọc
3K
nguyendang95
N
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Cảm ơn
Trả lời
5
Đọc
758
hoangtuan.net
hoangtuan.net
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2
Trả lời
35
Đọc
13K
minhys1
M
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
14 15 16
Trả lời
305
Đọc
21K
pkt.bacdau
pkt.bacdau
HONGVY91
Đếm số lượng 2 cột và đếm không trùng
Trả lời
2
Đọc
117
hoangtuaotrang_hp_vn
H
hanhlx88
Nhờ giúp file Excel báo lỗi: Excel cannot complete this task with available resources
Trả lời
3
Đọc
181
hanhlx88
hanhlx88
C
Trách nhiệm pháp lý của chi nhánh doanh nghiệp Việt Nam tại nước ngoài với Công ty tại Việt Nam
Trả lời
3
Đọc
110
VetMini
V
HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
73
Đọc
10K
HeSanbi
HeSanbi
L
Folder chứa chương trình bị khóa bởi Lock folder
2
Trả lời
28
Đọc
25K
qthangvphaui
Q
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
4
Đọc
142
phambahoang
P
N
Tính tổng với điều kiện gần đúng
Trả lời
3
Đọc
67
HUONGHCKT
H
Bùi Thúy Thúy
  • Question Question
Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công
2 3 4
Trả lời
63
Đọc
19K
Mutants Men
M
Anxseo
  • Đã khóa
Cách crack my excel
Trả lời
1
Đọc
177
HeSanbi
HeSanbi
phatnguyen7301
  • Question Question
Tạo âm thanh khi nhấn vào một phím
Trả lời
5
Đọc
245
yaaasoo01
Y
anhtuan1066
  • Question Question
Chèn hình vào cell bằng hàm tự tạo
    • Thích
    • Ngạc nhiên
10 11 12
Trả lời
235
Đọc
106K
XaNguyen
X
vc_đi chơi
Khóa Hoặc mã hóa File excel có độ bảo mật cao
    • Cảm ơn
    • Thích
Trả lời
3
Đọc
204
Hoangkhang01213
Hoangkhang01213
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom