Nhờ giúp em code vba tạo thêm 3 sheet mới có nội dung. (1 người xem)

  • Thread starter Thread starter xucxich
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

xucxich

Thành viên mới
Tham gia
19/5/13
Bài viết
45
Được thích
5
Nhờ các thầy, các anh trên GPE giúp em code VBA như sau:
Lúc ban đầu file của e chỉ có sheet "Thong-Ke". khi em chạy code thì chương trình sẽ tự động tạo ra 3 sheet: "So-Lieu", "Ket-Qua(1)", "Ket-Qua(2)"
- Với 2 sheet "Ket-Qua(1)", "Ket-Qua(2)" thì nội dung như trong file đính kèm.
- Với sheet "So-Lieu" có nội dung như file đính kèm và đồng thời copy nội dung 4 cột ở bên sheet "Thong-Ke" qua (4 cột màu vàng bên sheet "Thong-Ke" sẽ copy qua các cột tương ứng bên sheet "So-Lieu")
Sau khi tạo xong 3 sheet thì con trỏ chuột ở vị trí ô F2 của sheet "Du-Lieu"

Em cảm ơn!
 

File đính kèm

Nhờ các thầy, các anh trên GPE giúp em code VBA như sau:
(2) Lúc ban đầu file của e chỉ có sheet "Thong-Ke". khi em chạy code thì chương trình sẽ tự động tạo ra 3 sheet: "So-Lieu", "Ket-Qua(1)", "Ket-Qua(2)"
(2.0)- Với 2 sheet "Ket-Qua(1)", "Ket-Qua(2)" thì nội dung như trong file đính kèm.
(1) - Với sheet "So-Lieu" có nội dung như file đính kèm và đồng thời copy nội dung 4 cột ở bên sheet "Thong-Ke" qua (4 cột màu vàng bên sheet "Thong-Ke" sẽ copy qua các cột tương ứng bên sheet "So-Lieu")
(3) Sau khi tạo xong 3 sheet thì con trỏ chuột ở vị trí ô F2 của sheet "Du-Lieu"
Em cảm ơn!

(1) Ta chỉ việc tạo trang này 1 lần;
Những lần sau ta chỉ cần xóa đi dữ liệu sau dòng 8 là đạt iêu cầu đề ra;
Chuyện này không khó.

Vời (2) & (2.0): Thì cũng tương tự trên;

(3) Chuyện này cũng không khó lắm với VBA;

Cái khó là chưa chắc hiểu đúng í bạn;
 
Upvote 0
(1) Ta chỉ việc tạo trang này 1 lần;
Những lần sau ta chỉ cần xóa đi dữ liệu sau dòng 8 là đạt iêu cầu đề ra;
Chuyện này không khó.

Vời (2) & (2.0): Thì cũng tương tự trên;

(3) Chuyện này cũng không khó lắm với VBA;

Cái khó là chưa chắc hiểu đúng í bạn;

ý của e là 3 sheet: "So-Lieu", "Ket-Qua(1)", "Ket-Qua(2)" là 3 sheet chỉ được tạo ra khi ta chạy code thôi a ah.
Lúc ban đầu chỉ có duy nhất sheet "Thong-ke".
Ví du:
em tạo 1 sheet "Thong-ke" và tiến hành thống kê. khi thống kê xong e chạy code vba thì sẽ tự động tạo ra 3 sheet: "So-Lieu", "Ket-Qua(1)", "Ket-Qua(2)" có nội dung như ở file đính kèm bài #1.
Trong 3 sheet đó chỉ có sheet "So-Lieu" là thêm phần copy 4 cột e đánh dấu màu vàng ở bên sheet "Thong-ke" qua.
Còn 2 sheet "Ket-Qua(1)", "Ket-Qua(2)" thì giống file đính kèm.

Em trình bày vậy hy vọng giúp các anh dễ hiểu.
Nhờ các anh xem giúp cho.
Em cảm ơn!
 
Upvote 0
ý của e là 3 sheet: "So-Lieu", "Ket-Qua(1)", "Ket-Qua(2)" là 3 sheet chỉ được tạo ra khi ta chạy code thôi a ah.
Lúc ban đầu chỉ có duy nhất sheet "Thong-ke".
Ví du:
em tạo 1 sheet "Thong-ke" và tiến hành thống kê. khi thống kê xong e chạy code vba thì sẽ tự động tạo ra 3 sheet: "So-Lieu", "Ket-Qua(1)", "Ket-Qua(2)" có nội dung như ở file đính kèm bài #1.
Trong 3 sheet đó chỉ có sheet "So-Lieu" là thêm phần copy 4 cột e đánh dấu màu vàng ở bên sheet "Thong-ke" qua.
Còn 2 sheet "Ket-Qua(1)", "Ket-Qua(2)" thì giống file đính kèm.

Em trình bày vậy hy vọng giúp các anh dễ hiểu.
Nhờ các anh xem giúp cho.
Em cảm ơn!
Không có người trả lời là do mọi người không hiểu ý của bạn. Như đề xuất của bác HYen17, sao bạn không tạo ngay từ đầu mà cứ phải dùng code để tạo vì dữ liệu trên đó là cố định mà.
 
Upvote 0
ý của e là 3 sheet: "So-Lieu", "Ket-Qua(1)", "Ket-Qua(2)" là 3 sheet chỉ được tạo ra khi ta chạy code thôi a ah.
Lúc ban đầu chỉ có duy nhất sheet "Thong-ke".
Ví du:
em tạo 1 sheet "Thong-ke" và tiến hành thống kê. khi thống kê xong e chạy code vba thì sẽ tự động tạo ra 3 sheet: "So-Lieu", "Ket-Qua(1)", "Ket-Qua(2)" có nội dung như ở file đính kèm bài #1.
Trong 3 sheet đó chỉ có sheet "So-Lieu" là thêm phần copy 4 cột e đánh dấu màu vàng ở bên sheet "Thong-ke" qua.
Còn 2 sheet "Ket-Qua(1)", "Ket-Qua(2)" thì giống file đính kèm.

Em trình bày vậy hy vọng giúp các anh dễ hiểu.
Nhờ các anh xem giúp cho.
Em cảm ơn!
Làm đại cho bạn như file đính kèm.
 

File đính kèm

Upvote 0
Cảm ơn ban!
file đính kèm của bạn đã đáp ứng được yêu cầu của mình.
chỉ có cột số lượng và chiều dài là bị copy nhầm vị trí nhau thôi.
mình đã thay đổi vị trí của nó những vẫn ko copy được đúng vị trí.
mình nghĩ chắc ở đoạn code này thôi, bạn xem giúp mình
Mã:
            Union(.Range("C13:C" & endR), .Range("I13:I" & endR), .Range("M13:M" & endR), .Range("J13:J" & endR)).Copy [c9]

p/s: Thực sự làm như yêu cầu của mình thì các sheet được trình bày ko đẹp như mẫu.
 
Upvote 0
Không có người trả lời là do mọi người không hiểu ý của bạn. Như đề xuất của bác HYen17, sao bạn không tạo ngay từ đầu mà cứ phải dùng code để tạo vì dữ liệu trên đó là cố định mà.

Bảng thống kê này được tạo từ ad-ins thống kê thép của một bạn đồng nghiệp chia sẻ. với ad-ins này thì mình tạo được các bảng thống kê để thống kê thép.
mình muốn phát triển cho nó thêm một ứng dụng nữa liên quan đến các số liệu trong bảng thống kê nên mình mới nhờ giúp về code vba.
Ý kiến của bạn mình sẽ tiếp thu, có thể tạo 3 sheet trước, rồi sau đó chỉ việc dùng code copy 3 sheet là ok. lại được cái dễ dàng trình bày mẫu mã đẹp nữa.
cảm ơn bạn!
 
Upvote 0
Cảm ơn ban!
file đính kèm của bạn đã đáp ứng được yêu cầu của mình.
chỉ có cột số lượng và chiều dài là bị copy nhầm vị trí nhau thôi.
mình đã thay đổi vị trí của nó những vẫn ko copy được đúng vị trí.
mình nghĩ chắc ở đoạn code này thôi, bạn xem giúp mình
Mã:
            Union(.Range("C13:C" & endR), .Range("I13:I" & endR), .Range("M13:M" & endR), .Range("J13:J" & endR)).Copy [c9]

p/s: Thực sự làm như yêu cầu của mình thì các sheet được trình bày ko đẹp như mẫu.
Bạn chỉnh code lại như sau:

Mã:
Sub Test()
Dim endR As Integer
Application.ScreenUpdating = False
    Call xoa
    With Sheet1
        endR = .Range("C65000").End(xlUp).Row
        Worksheets.Add
            ActiveSheet.Name = "So-Lieu"
            Range("solieu").Copy [b2]
            Union(.Range("C13:C" & endR), .Range("I13:I" & endR), .Range("M13:M" & endR)).Copy [c9]
            .Range("J13:J" & endR).Copy [f9]
            Range("B9:B" & [c65000].End(xlUp).Row).FormulaR1C1 = "=ROW()-8"
            Cells.EntireColumn.AutoFit
        Worksheets.Add
            ActiveSheet.Name = "Ket-Qua(1)"
            Range("ketqua1").Copy [a1]
            Cells.EntireColumn.AutoFit
        Worksheets.Add
            ActiveSheet.Name = "Ket-Qua(2)"
            Range("ketqua2").Copy [a1]
            Cells.EntireColumn.AutoFit
        .Select
    End With
Application.ScreenUpdating = True

End Sub
 

File đính kèm

Upvote 0
Bạn chỉnh code lại như sau:

Mã:
Sub Test()
Dim endR As Integer
Application.ScreenUpdating = False
    Call xoa
    With Sheet1
        endR = .Range("C65000").End(xlUp).Row
        Worksheets.Add
            ActiveSheet.Name = "So-Lieu"
            Range("solieu").Copy [b2]
            Union(.Range("C13:C" & endR), .Range("I13:I" & endR), .Range("M13:M" & endR)).Copy [c9]
            .Range("J13:J" & endR).Copy [f9]
            Range("B9:B" & [c65000].End(xlUp).Row).FormulaR1C1 = "=ROW()-8"
            Cells.EntireColumn.AutoFit
        Worksheets.Add
            ActiveSheet.Name = "Ket-Qua(1)"
            Range("ketqua1").Copy [a1]
            Cells.EntireColumn.AutoFit
        Worksheets.Add
            ActiveSheet.Name = "Ket-Qua(2)"
            Range("ketqua2").Copy [a1]
            Cells.EntireColumn.AutoFit
        .Select
    End With
Application.ScreenUpdating = True

End Sub

Cảm ơn bạn!
Mình có câu hỏi này nhờ bạn.
1. Đoạn code xóa nếu trường hợp sheet Thong-Ke ko phải là sheet1 thì sẽ xóa hết.
Mình sửa đoạn code xóa lại như bên dưới mà nó ko chạy, nhờ bạn xem giúp.
Mã:
Sub xoa()
Dim sh As Worksheet
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Sheets
    If UCase(sh.Name) = "So-Lieu" Then
        sh.Delete
    End If
    If UCase(sh.Name) = "Ket-Qua(1)" Then
        sh.Delete
    End If
    If UCase(sh.Name) = "Ket-Qua(2)" Then
        sh.Delete
    End If
Next
Application.DisplayAlerts = True


End Sub
2. Cái này mình mới phát hiện ra thôi nên bạn thông cảm vì mình không đưa vào yêu cầu ngay lúc đầu. nhờ bạn giúp mình chỉnh lại đoạn code copy phần chiều dài sao cho copy qua bên sheet số liệu thì tất cả chiều dài đều chia cho 1000. (mình muốn đổi từ đơn vị mm sang đơn vị m)
 
Upvote 0
Cảm ơn bạn!
Mình có câu hỏi này nhờ bạn.
1. Đoạn code xóa nếu trường hợp sheet Thong-Ke ko phải là sheet1 thì sẽ xóa hết.
Mình sửa đoạn code xóa lại như bên dưới mà nó ko chạy, nhờ bạn xem giúp.
Mã:
Sub xoa()
Dim sh As Worksheet
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Sheets
    If UCase(sh.Name) = "So-Lieu" Then
        sh.Delete
    End If
    If UCase(sh.Name) = "Ket-Qua(1)" Then
        sh.Delete
    End If
    If UCase(sh.Name) = "Ket-Qua(2)" Then
        sh.Delete
    End If
Next
Application.DisplayAlerts = True


End Sub
2. Cái này mình mới phát hiện ra thôi nên bạn thông cảm vì mình không đưa vào yêu cầu ngay lúc đầu. nhờ bạn giúp mình chỉnh lại đoạn code copy phần chiều dài sao cho copy qua bên sheet số liệu thì tất cả chiều dài đều chia cho 1000. (mình muốn đổi từ đơn vị mm sang đơn vị m)
1./ Chỉnh lại code xóa sheet:

Mã:
Sub xoa()
Dim sh As Worksheet
Application.DisplayAlerts = False
For Each sh In ThisWorkbook.Sheets
    If UCase(sh.Name) = "SO-LIEU" Or UCase(sh.Name) = "KET-QUA(1)" Or UCase(sh.Name) = "KET-QUA(2)" Then
        sh.Delete
    End If
Next
Application.DisplayAlerts = True

End Sub

2./ Chỉnh lại code theo yêu cầu của bạn:

Mã:
Sub Test()
Dim endR As Integer
Application.ScreenUpdating = False
    Call xoa
    With Sheet1
        endR = .Range("C65000").End(xlUp).Row
        Worksheets.Add
            ActiveSheet.Name = "So-Lieu"
            Range("solieu").Copy [b2]
            Union(.Range("C13:C" & endR), .Range("I13:I" & endR), .Range("M13:M" & endR)).Copy [c9]
            .Range("J13:J" & endR).Copy [f9]
            .Range("AC8").Copy: Range("F9:F" & [F65000].End(xlUp).Row).PasteSpecial 1, xlDivide
            [a1].Select
            Range("B9:B" & [c65000].End(xlUp).Row).FormulaR1C1 = "=ROW()-8"
            Cells.EntireColumn.AutoFit
        Worksheets.Add
            ActiveSheet.Name = "Ket-Qua(1)"
            Range("ketqua1").Copy [a1]
            Cells.EntireColumn.AutoFit
        Worksheets.Add
            ActiveSheet.Name = "Ket-Qua(2)"
            Range("ketqua2").Copy [a1]
            Cells.EntireColumn.AutoFit
        .Select
    End With
Application.ScreenUpdating = True

End Sub
 

File đính kèm

Upvote 0
Mã:
.Range("J9").Copy: Range("F9:F" & [F65000].End(xlUp).Row).PasteSpecial 1, xlDivide
Đoạn code trên bạn cho nó copy nguyên công thức, nên dễ bị lỗi nếu ô được copy là công thức chứ ko phải là 1 số liệu cụ thể.
Bạn có thể giúp sửa nó sao cho chỉ copy giá trị và chia cho 1000.
mình cảm ơn!
 
Upvote 0
Mã:
.Range("J9").Copy: Range("F9:F" & [F65000].End(xlUp).Row).PasteSpecial 1, xlDivide
Đoạn code trên bạn cho nó copy nguyên công thức, nên dễ bị lỗi nếu ô được copy là công thức chứ ko phải là 1 số liệu cụ thể.
Bạn có thể giúp sửa nó sao cho chỉ copy giá trị và chia cho 1000.
mình cảm ơn!

Gán đại cho cell nào đó là 1000 rồi copy nó dán vào là được.

Mã:
Sub Test()
Dim endR As Integer
Application.ScreenUpdating = False
    Call xoa
    With Sheet1
        endR = .Range("C65000").End(xlUp).Row
        Worksheets.Add
            ActiveSheet.Name = "So-Lieu"
            Range("solieu").Copy [b2]
            Union(.Range("C13:C" & endR), .Range("I13:I" & endR), .Range("M13:M" & endR)).Copy [c9]
            .Range("J13:J" & endR).Copy [f9]
           [COLOR=#0000cd] .[IV1].Value = 1000: .[IV1].Copy[/COLOR]
            Range("F9:F" & [F65000].End(xlUp).Row).PasteSpecial 1, xlDivide
            [a1].Select
            Range("B9:B" & [c65000].End(xlUp).Row).FormulaR1C1 = "=ROW()-8"
            Cells.EntireColumn.AutoFit
        Worksheets.Add
            ActiveSheet.Name = "Ket-Qua(1)"
            Range("ketqua1").Copy [a1]
            Cells.EntireColumn.AutoFit
        Worksheets.Add
            ActiveSheet.Name = "Ket-Qua(2)"
            Range("ketqua2").Copy [a1]
            Cells.EntireColumn.AutoFit
        .Select
    End With
Application.ScreenUpdating = True

End Sub
 

File đính kèm

Upvote 0
Cảm ơn bạn!
ý của mình là nếu ở cột J là công thức chứ không phải giá trị được nhập vào thì khi chạy code sẽ bị lỗi.
Mình có gửi file đính kèm, bạn xem chạy code sẽ thấy lỗi.
 

File đính kèm

Upvote 0
Cảm ơn bạn!
ý của mình là nếu ở cột J là công thức chứ không phải giá trị được nhập vào thì khi chạy code sẽ bị lỗi.
Mình có gửi file đính kèm, bạn xem chạy code sẽ thấy lỗi.
Chuyển cột đó về giá trị là được.
Mã:
Sub Test()
Dim endR As Integer
Application.ScreenUpdating = False
    Call xoa
    With Sheet1
        endR = .Range("C65000").End(xlUp).Row
        Worksheets.Add
            ActiveSheet.Name = "So-Lieu"
            Range("solieu").Copy [b2]
            Union(.Range("C13:C" & endR), .Range("I13:I" & endR), .Range("M13:M" & endR)).Copy [c9]
            [COLOR=#0000ff].Range("J13:J" & endR).Copy: [f9].PasteSpecial 3[/COLOR]
            .[IV1].Value = 1000: .[IV1].Copy
            Range("F9:F" & [F65000].End(xlUp).Row).PasteSpecial 1, xlDivide
            [a1].Select
            Range("B9:B" & [c65000].End(xlUp).Row).FormulaR1C1 = "=ROW()-8"
            Cells.EntireColumn.AutoFit
        Worksheets.Add
            ActiveSheet.Name = "Ket-Qua(1)"
            Range("ketqua1").Copy [a1]
            Cells.EntireColumn.AutoFit
        Worksheets.Add
            ActiveSheet.Name = "Ket-Qua(2)"
            Range("ketqua2").Copy [a1]
            Cells.EntireColumn.AutoFit
        .Select
    End With
Application.ScreenUpdating = True

End Sub
 

File đính kèm

Upvote 0

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

Back
Top Bottom