Lập lại tiêu đề cho từng dòng dữ liệu

[langtu020690]

Hi ad
Mình đã làm theo như video ad gửi và đã làm ra, nhưng thứ tự ad chọn vẫn chưa đúng với ý của cái form 3 khung đỏ. Vả lại trong code còn những đoạn fix sẵn dãy range (vd như Wb.Sheets("Data").Range("A5:S5").Resize(Lap).Copy Sh.Range("A3")). Nên nếu file add-in này gửi dùng cho 1 bảng lương khác sẽ bị lỗi. E giải thích tý


-----------
Em nói từng hình nha
Hình 1:
a. Khung xanh là tiêu đề muốn lập lại, tương ứng với hình 2 là khung đỏ đầu tiên (titles range)
b. Khung vàng là vùng dữ liệu muốn tiêu đề lập lại, tương ứng với hình 2 là khung đỏ thứ 2 (insert range)
Hình 2:
a. Khung đỏ thứ 3 (interval Rows) là bao nhiêu dòng dữ liệu thì cho tiêu đề lập lại 1 lần
Ví dụ 1: Nếu khung đỏ thứ 2 (insert range) chọn 3 người, và muốn mỗi người tiêu đề lập lại 1 lần thì interval rows = 1, kết quả sẽ ra giống hình 4

Ví dụ 2: Nếu khung đỏ thứ 2 (insert range) chọn 4 người, và muốn cứ 2 người tiêu đề lập lại 1 lần thì interval rows = 2, kết quả sẽ ra giống hình 5

---------
Mục đích và tất cả các input đều thông qua từ hình 2, và bất kỳ file nào, bảng lương or 1 bảng nào đó đều có thể dùng dc. Hiện tại trong code của ad, e thấy còn 1 vài chỗ fix cứng. Ad xem dùm e nha, e nghĩ chúng ta đi dc 90% đoạn đường rồi, do em mới học nên k có tầm để sửa code. Một lần nữa tks ad

 

[giaiphap]

Hi ad

Em có tí ý kiến, ad xem hợp lý ko nha, hiện tại e đã vào máy office 2007, down và cải IDBE RibbonCreator (Office 2007), giờ từ file xlam của ad, e làm sao để nó lưu lại thành xlsm, sao đó thử tạo mới add-in bằng bảng 2007. Nhưng suy cho cùng e thấy bắt tiện vì phải chuyển qua chuyển lại. Không biết có cách nào khác không

Trước hết bạn vào excel 2007 để tạo file xlsm, sau đó dùng ribboncreate để tạo ribbon cho file xlsm xem có được không, nếu excel 2007 của bạn xem được ribbon và chạy được code của file xlsm thì bạn gửi file đó lên đây tôi sẽ giúp tiếp cho (do hướng dẫn mất nhiều bước mặc dù không khó). Khi tạo add-ins cho excel 2007 chạy được thì excel 2010, 2013, 2016... cũng chạy được.

 

[langtu020690]

Trước hết bạn vào excel 2007 để tạo file xlsm, sau đó dùng ribboncreate để tạo ribbon cho file xlsm xem có được không, nếu excel 2007 của bạn xem được ribbon và chạy được code của file xlsm thì bạn gửi file đó lên đây tôi sẽ giúp tiếp cho (do hướng dẫn mất nhiều bước mặc dù không khó). Khi tạo add-ins cho excel 2007 chạy được thì excel 2010, 2013, 2016... cũng chạy được.

Dear ad
Em liệt kê trình tự các bước e làm, ad xem và cho e ý kiến đúng hay sai nha
B1. Em tạo 1 file excel bất kỳ (vd test.xlsm)
B2: Em copy đoạn customUI của ad mà viết cho office 2007 để tạo 1 customUI cho file test.xlsm (vì ban đầu e dùng Ribbon Creator 2007 mở file test.xlsm ko dc, nó nói k có file customUI.xml)
B3: Em dùng Ribbon Creator mở file test.xlsm lên thì mở dc file, thấy có hiện lên thanh riboon
B4: hiện tại e cần làm gì tiếp theo để có thể lưu file xlam, bản thân e nghỉ là e mở file test.xlsm copy code củ và tạo 1 userform mới phải k ad. Có cách nào làm nhanh hơn ko.

 

[giaiphap]

Dear ad
Em liệt kê trình tự các bước e làm, ad xem và cho e ý kiến đúng hay sai nha
B1. Em tạo 1 file excel bất kỳ (vd test.xlsm)
B2: Em copy đoạn customUI của ad mà viết cho office 2007 để tạo 1 customUI cho file test.xlsm (vì ban đầu e dùng Ribbon Creator 2007 mở file test.xlsm ko dc, nó nói k có file customUI.xml)
B3: Em dùng Ribbon Creator mở file test.xlsm lên thì mở dc file, thấy có hiện lên thanh riboon
B4: hiện tại e cần làm gì tiếp theo để có thể lưu file xlam, bản thân e nghỉ là e mở file test.xlsm copy code củ và tạo 1 userform mới phải k ad. Có cách nào làm nhanh hơn ko.

Bạn thực hiện vậy đúng rồi, chỉ có điều file của tôi được tạo từ IDBE RibbonCreator 2010 nên excel 2007 sẽ không mở được. Vậy bạn cứ dùng IDBE RibbonCreator 2007 để tạo file xlsm sau khi file đã hoàn chỉnh muốn lưu lại thành Add-Ins thì bạn save as lại và chọn giống như hình dưới.

Bạn không cần copy code sẽ rất lâu, bạn chỉ cần dùng 2 chức năng (Bạn có thể tự test là biết ngay kết quả) tôi đóng khung như hình dưới là được.

 

[langtu020690]

Bạn thực hiện vậy đúng rồi, chỉ có điều file của tôi được tạo từ IDBE RibbonCreator 2010 nên excel 2007 sẽ không mở được. Vậy bạn cứ dùng IDBE RibbonCreator 2007 để tạo file xlsm sau khi file đã hoàn chỉnh muốn lưu lại thành Add-Ins thì bạn save as lại và chọn giống như hình dưới.
View attachment 220267
Bạn không cần copy code sẽ rất lâu, bạn chỉ cần dùng 2 chức năng (Bạn có thể tự test là biết ngay kết quả) tôi đóng khung như hình dưới là được.
View attachment 220268

Hi ad
Em làm được rồi, đã hiện lên ribbon rồi, nhưng khi vừa add add-in xong thì add-in tiện ích chèn vị trí đầu tiên luôn (trước thẻ HOME) mình chỉnh sau để nó về vị trí cuối cùng vậy ad

 

[giaiphap]

Hi ad
Em làm được rồi, đã hiện lên ribbon rồi, nhưng khi vừa add add-in xong thì add-in tiện ích chèn vị trí đầu tiên luôn (trước thẻ HOME) mình chỉnh sau để nó về vị trí cuối cùng vậy ad

Bạn mở file customUi.xml lên và xóa chổ này insertBeforeMso = "TabHome" là được.

 

[langtu020690]

Bạn mở file customUi.xml lên và xóa chổ này insertBeforeMso = "TabHome" là được.

Dear Ad
Chủ đề này tới hôm nay đã được close. Em cảm ơn ad đã hỗ trợ nha, VBA thì e cũng đang bắt đầu xem, thấy VBA hay thiệt

 

[ThangCuAnh]

Tự mày mò làm được cảm giác nó tuyệt hơn để người khác làm giùm hết 100% phải kg bạn?

 

[langtu020690]

Tự mày mò làm được cảm giác nó tuyệt hơn để người khác làm giùm hết 100% phải kg bạn?

Dear
Đúng rồi, nói thật khi mình post bài hỏi ad, bản thân mình cũng tự thân vận động. Vì chỉ do là mới bắt đầu nên còn cần chỉ bảo nhiều. Đơn thuần đây chỉ là 1 add-in nhưng tính ra kiến thức để làm dc nó kết hợp rất nhiều thứ, họ thêm được nhiều thứ

 

[langtu020690]

Dear giaiphap
Sau 1 quá trình sử dụng file này, thì có 1 khuyết nhỏ mà e vẫn chưa chỉnh được. E nói ra nhờ giaiphap xem giúp e. VD sheet lương ban đầu đã format nằm trong 1 trang in, khi mình lập lại tiêu đề thì add-in sẽ tự tạo 1 sheet khác thì format ban đầu ko còn giữ lại nữa. Phải kéo bằng tay. Có cách này sao khi nó copy luôn cái format ban đâu luôn ko a
@file e gửi là file cuối cùng, có thể dùng dc trên office 2007

 

[giaiphap]

Dear giaiphap
Sau 1 quá trình sử dụng file này, thì có 1 khuyết nhỏ mà e vẫn chưa chỉnh được. E nói ra nhờ giaiphap xem giúp e. VD sheet lương ban đầu đã format nằm trong 1 trang in, khi mình lập lại tiêu đề thì add-in sẽ tự tạo 1 sheet khác thì format ban đầu ko còn giữ lại nữa. Phải kéo bằng tay. Có cách này sao khi nó copy luôn cái format ban đâu luôn ko a
@file e gửi là file cuối cùng, có thể dùng dc trên office 2007

Là do code copy dữ liệu qua sheet mới nên nó sẽ khác là đúng rồi, vậy nếu bạn muốn giữ thế nào thì đưa cái file mẫu đó lên đây để tôi xem và nghiên cứu.

 

[langtu020690]

Là do code copy dữ liệu qua sheet mới nên nó sẽ khác là đúng rồi, vậy nếu bạn muốn giữ thế nào thì đưa cái file mẫu đó lên đây để tôi xem và nghiên cứu.

Hi ad

Em gửi đính kèm lại file add-in đã hoàn chỉnh ban đầu + 1 file lương. Mong muốn là trong file lương các cột và dòng có độ rộng và dài của của tiêu đề như thế nào thì qua sheet copy nó cũng như vậy luôn. Hiện tại mỗi lần copy xong, em phải chỉnh sửa (kéo độ dài cột, hàng)

 

[giaiphap]

Hi ad

Em gửi đính kèm lại file add-in đã hoàn chỉnh ban đầu + 1 file lương. Mong muốn là trong file lương các cột và dòng có độ rộng và dài của của tiêu đề như thế nào thì qua sheet copy nó cũng như vậy luôn. Hiện tại mỗi lần copy xong, em phải chỉnh sửa (kéo độ dài cột, hàng)

Sửa lại code cho nút OK thế này xem sao.

Private Sub CommandButton1_Click()
    Dim i As Integer, s1 As String, s2 As String, s3 As String, s4 As String, Lap As Integer, s5 As String, s6 As String
    Dim cCol As Long, cRow As Long, hang As Long
    Dim Sh As Worksheet, Wb As Workbook
    If InStr(1, Reftitle.Text, "!") > 0 Then
        s1 = Left(Reftitle.Text, InStr(1, Reftitle.Text, "!") - 1)
        s2 = Right(Reftitle.Text, Len(Reftitle.Text) - InStr(1, Reftitle.Text, "!"))
    Else
        s1 = ActiveSheet.Name
        s2 = Reftitle.Text
    End If
        
    If InStr(1, RefRng.Text, "!") > 0 Then
        s3 = Left(RefRng.Text, InStr(1, RefRng.Text, "!") - 1)
        s4 = Right(RefRng.Text, Len(RefRng.Text) - InStr(1, RefRng.Text, "!"))
    Else
        s3 = ActiveSheet.Name
        s4 = RefRng.Text
    End If
    '---
    If InStr(1, RefEdit1.Text, "!") > 0 Then
        s5 = Left(RefEdit1.Text, InStr(1, RefEdit1.Text, "!") - 1)
        s6 = Right(RefEdit1.Text, Len(RefEdit1.Text) - InStr(1, RefEdit1.Text, "!"))
    Else
        s5 = ActiveSheet.Name
        s6 = RefEdit1.Text
    End If
    '---
    s1 = Replace(s1, "'", "")
    s3 = Replace(s3, "'", "")
    Lap = Val(TxtRow.Text)
    If Reftitle.Text = "" Or RefRng.Text = "" Then
        MsgBox "Ban chua nhap du du lieu"
        Exit Sub
    End If
    If Lap = 0 Then
        MsgBox "Ban nen xem lai muc Interval Rows"
        Exit Sub
    End If
    'cCol = Rng.Columns.Count
    Set Rng = Range(s6)
    cCol = Rng.Columns.Count
    Set Wb = ActiveWorkbook
    If Wb.Sheets(s1).Range(s4).Columns.Count <> cCol Then
        MsgBox "So cot giua tieu de lap lai va du lieu khong bang nhau"
        Set Wb = Nothing
        Exit Sub
    End If
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        ActiveSheet.Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        Set Sh = ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        Sh.Cells.Clear
        Wb.Sheets(s1).Range(s2).Copy Sh.Range("A1")
        Sh.Range("A1").Resize(, cCol).HorizontalAlignment = xlCenterAcrossSelection
        cRow = Wb.Sheets(s3).Range(s4).Rows.Count
        Rng.Copy Sh.Range("A3").Offset(cRow - 1)
        hang = 3 + cRow + Int(Rng.Rows.Count / Lap) * Lap + IIf(Rng.Rows.Count Mod Lap = 0, -Lap, 0)
        For i = hang To (3 + cRow) Step -Lap
            Sh.Rows((i - 1) & ":" & (i + cRow - 2)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Wb.Sheets(s3).Range(s4).Copy Sh.Range("A" & (i - 1))
        Next
        Set Wb = Nothing
        Set Sh = Nothing
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    Unload Me
End Sub

 

[langtu020690]

Sửa lại code cho nút OK thế này xem sao.

Private Sub CommandButton1_Click()
    Dim i As Integer, s1 As String, s2 As String, s3 As String, s4 As String, Lap As Integer, s5 As String, s6 As String
    Dim cCol As Long, cRow As Long, hang As Long
    Dim Sh As Worksheet, Wb As Workbook
    If InStr(1, Reftitle.Text, "!") > 0 Then
        s1 = Left(Reftitle.Text, InStr(1, Reftitle.Text, "!") - 1)
        s2 = Right(Reftitle.Text, Len(Reftitle.Text) - InStr(1, Reftitle.Text, "!"))
    Else
        s1 = ActiveSheet.Name
        s2 = Reftitle.Text
    End If
       
    If InStr(1, RefRng.Text, "!") > 0 Then
        s3 = Left(RefRng.Text, InStr(1, RefRng.Text, "!") - 1)
        s4 = Right(RefRng.Text, Len(RefRng.Text) - InStr(1, RefRng.Text, "!"))
    Else
        s3 = ActiveSheet.Name
        s4 = RefRng.Text
    End If
    '---
    If InStr(1, RefEdit1.Text, "!") > 0 Then
        s5 = Left(RefEdit1.Text, InStr(1, RefEdit1.Text, "!") - 1)
        s6 = Right(RefEdit1.Text, Len(RefEdit1.Text) - InStr(1, RefEdit1.Text, "!"))
    Else
        s5 = ActiveSheet.Name
        s6 = RefEdit1.Text
    End If
    '---
    s1 = Replace(s1, "'", "")
    s3 = Replace(s3, "'", "")
    Lap = Val(TxtRow.Text)
    If Reftitle.Text = "" Or RefRng.Text = "" Then
        MsgBox "Ban chua nhap du du lieu"
        Exit Sub
    End If
    If Lap = 0 Then
        MsgBox "Ban nen xem lai muc Interval Rows"
        Exit Sub
    End If
    'cCol = Rng.Columns.Count
    Set Rng = Range(s6)
    cCol = Rng.Columns.Count
    Set Wb = ActiveWorkbook
    If Wb.Sheets(s1).Range(s4).Columns.Count <> cCol Then
        MsgBox "So cot giua tieu de lap lai va du lieu khong bang nhau"
        Set Wb = Nothing
        Exit Sub
    End If
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        ActiveSheet.Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        Set Sh = ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        Sh.Cells.Clear
        Wb.Sheets(s1).Range(s2).Copy Sh.Range("A1")
        Sh.Range("A1").Resize(, cCol).HorizontalAlignment = xlCenterAcrossSelection
        cRow = Wb.Sheets(s3).Range(s4).Rows.Count
        Rng.Copy Sh.Range("A3").Offset(cRow - 1)
        hang = 3 + cRow + Int(Rng.Rows.Count / Lap) * Lap + IIf(Rng.Rows.Count Mod Lap = 0, -Lap, 0)
        For i = hang To (3 + cRow) Step -Lap
            Sh.Rows((i - 1) & ":" & (i + cRow - 2)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Wb.Sheets(s3).Range(s4).Copy Sh.Range("A" & (i - 1))
        Next
        Set Wb = Nothing
        Set Sh = Nothing
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    Unload Me
End Sub

Dear ad
Tks ad nhiều, hiện tại chạy được rồi nha

 

[langtu020690]

Dear ad
Tks ad nhiều, hiện tại chạy được rồi nha

Hi ad
Các trường hợp thường tiêu đề lập lai chỉ có 1 hay 2 dòng thì OK, còn có nhiều dòng quá thì nó ra k đúng nữa. Không đúng ở đây cũng chính là định dạng độ rộng và cao của cột. Em gửi 1 phiếu lương, ad xem thử xem em
2 file đính kèm là file add-in đã sửa theo ý ad và file lương

Bài đã được tự động gộp: 18/7/19

Hi ad
Như em làm thì hình dưới chỉ đúng cho người thứ 5 thôi (e lập lại tiêu đề cho 5 người). Mấy người 1,2,3,4 thì phải kéo bằng tay

 

[giaiphap]

Hi ad
Các trường hợp thường tiêu đề lập lai chỉ có 1 hay 2 dòng thì OK, còn có nhiều dòng quá thì nó ra k đúng nữa. Không đúng ở đây cũng chính là định dạng độ rộng và cao của cột. Em gửi 1 phiếu lương, ad xem thử xem em
2 file đính kèm là file add-in đã sửa theo ý ad và file lương

Bài đã được tự động gộp: 18/7/19

Hi ad
Như em làm thì hình dưới chỉ đúng cho người thứ 5 thôi (e lập lại tiêu đề cho 5 người). Mấy người 1,2,3,4 thì phải kéo bằng tay
View attachment 221397

Do code chỉ chạy để đưa dữ liệu vào thôi, không có định dạng hay thay đổi chiều cao các hàng chính vì vậy khi đưa dữ liệu vào thì cái hàng vẫn giữ nguyên chiều cao, nhưng tiêu đề lại có chiều cao không tương thích nên nó bị vậy là đúng rồi.
Tôi viết lại code để thay đổi chiều cao của hàng luôn bạn thử và xem kết quả thế nào. Do vừa đưa dữ liệu vào vừa thay đổi độ cao của hàng nên tốc độ sẽ chậm nếu có dữ liệu nhiều.

Private Sub CommandButton1_Click()
    Dim i As Integer, s1 As String, s2 As String, s3 As String, s4 As String, Lap As Integer, s5 As String, s6 As String
    Dim cCol As Long, cRow As Long, hang As Long, j As Long, k As Long
    Dim Sh As Worksheet, Wb As Workbook
    If InStr(1, Reftitle.Text, "!") > 0 Then
        s1 = Left(Reftitle.Text, InStr(1, Reftitle.Text, "!") - 1)
        s2 = Right(Reftitle.Text, Len(Reftitle.Text) - InStr(1, Reftitle.Text, "!"))
    Else
        s1 = ActiveSheet.Name
        s2 = Reftitle.Text
    End If
        
    If InStr(1, RefRng.Text, "!") > 0 Then
        s3 = Left(RefRng.Text, InStr(1, RefRng.Text, "!") - 1)
        s4 = Right(RefRng.Text, Len(RefRng.Text) - InStr(1, RefRng.Text, "!"))
    Else
        s3 = ActiveSheet.Name
        s4 = RefRng.Text
    End If
    '---
    If InStr(1, RefEdit1.Text, "!") > 0 Then
        s5 = Left(RefEdit1.Text, InStr(1, RefEdit1.Text, "!") - 1)
        s6 = Right(RefEdit1.Text, Len(RefEdit1.Text) - InStr(1, RefEdit1.Text, "!"))
    Else
        s5 = ActiveSheet.Name
        s6 = RefEdit1.Text

    End If
    '---
    s1 = Replace(s1, "'", "")
    s3 = Replace(s3, "'", "")
    Lap = Val(TxtRow.Text)
    If Reftitle.Text = "" Or RefRng.Text = "" Then
        MsgBox "Ban chua nhap du du lieu"
        Exit Sub
    End If
    If Lap = 0 Then
        MsgBox "Ban nen xem lai muc Interval Rows"
        Exit Sub
    End If
    Set Rng = Range(s6)
    cCol = Rng.Columns.Count
    Set Wb = ActiveWorkbook
    If Wb.Sheets(s1).Range(s4).Columns.Count <> cCol Then
        MsgBox "So cot giua tieu de lap lai va du lieu khong bang nhau" & Chr(13) & Wb.Sheets(s1).Range(s4).Columns.Count & " - " & cCol
        Set Wb = Nothing
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        ActiveSheet.Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        Set Sh = ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        Sh.Cells.Clear
        Sh.UsedRange.Rows.RowHeight = Rng.Rows(1).RowHeight
        Wb.Sheets(s1).Range(s2).Copy Sh.Range("A1")
        Sh.Range("A1").Resize(, cCol).HorizontalAlignment = xlCenterAcrossSelection
        cRow = Wb.Sheets(s3).Range(s4).Rows.Count
        k = Wb.Sheets(s3).Range(s4).Row
        Rng.Copy Sh.Range("A3").Offset(cRow - 1)
        hang = 3 + cRow + Int(Rng.Rows.Count / Lap) * Lap + IIf(Rng.Rows.Count Mod Lap = 0, -Lap, 0)
        For i = hang To (3 + cRow) Step -Lap
            Sh.Rows((i - 1) & ":" & (i + cRow - 2)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Wb.Sheets(s3).Range(s4).Copy Sh.Range("A" & (i - 1))
            For j = 1 To cRow
                Sh.Rows(i + j - 2 & ":" & i + j - 2).RowHeight = Wb.Sheets(s3).Rows(k + j - 1 & ":" & k + j - 1).RowHeight
            Next j
        Next
        Set Wb = Nothing
        Set Sh = Nothing
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    Unload Me
End Sub

 

[langtu020690]

Do code chỉ chạy để đưa dữ liệu vào thôi, không có định dạng hay thay đổi chiều cao các hàng chính vì vậy khi đưa dữ liệu vào thì cái hàng vẫn giữ nguyên chiều cao, nhưng tiêu đề lại có chiều cao không tương thích nên nó bị vậy là đúng rồi.
Tôi viết lại code để thay đổi chiều cao của hàng luôn bạn thử và xem kết quả thế nào. Do vừa đưa dữ liệu vào vừa thay đổi độ cao của hàng nên tốc độ sẽ chậm nếu có dữ liệu nhiều.

Private Sub CommandButton1_Click()
    Dim i As Integer, s1 As String, s2 As String, s3 As String, s4 As String, Lap As Integer, s5 As String, s6 As String
    Dim cCol As Long, cRow As Long, hang As Long, j As Long, k As Long
    Dim Sh As Worksheet, Wb As Workbook
    If InStr(1, Reftitle.Text, "!") > 0 Then
        s1 = Left(Reftitle.Text, InStr(1, Reftitle.Text, "!") - 1)
        s2 = Right(Reftitle.Text, Len(Reftitle.Text) - InStr(1, Reftitle.Text, "!"))
    Else
        s1 = ActiveSheet.Name
        s2 = Reftitle.Text
    End If
       
    If InStr(1, RefRng.Text, "!") > 0 Then
        s3 = Left(RefRng.Text, InStr(1, RefRng.Text, "!") - 1)
        s4 = Right(RefRng.Text, Len(RefRng.Text) - InStr(1, RefRng.Text, "!"))
    Else
        s3 = ActiveSheet.Name
        s4 = RefRng.Text
    End If
    '---
    If InStr(1, RefEdit1.Text, "!") > 0 Then
        s5 = Left(RefEdit1.Text, InStr(1, RefEdit1.Text, "!") - 1)
        s6 = Right(RefEdit1.Text, Len(RefEdit1.Text) - InStr(1, RefEdit1.Text, "!"))
    Else
        s5 = ActiveSheet.Name
        s6 = RefEdit1.Text

    End If
    '---
    s1 = Replace(s1, "'", "")
    s3 = Replace(s3, "'", "")
    Lap = Val(TxtRow.Text)
    If Reftitle.Text = "" Or RefRng.Text = "" Then
        MsgBox "Ban chua nhap du du lieu"
        Exit Sub
    End If
    If Lap = 0 Then
        MsgBox "Ban nen xem lai muc Interval Rows"
        Exit Sub
    End If
    Set Rng = Range(s6)
    cCol = Rng.Columns.Count
    Set Wb = ActiveWorkbook
    If Wb.Sheets(s1).Range(s4).Columns.Count <> cCol Then
        MsgBox "So cot giua tieu de lap lai va du lieu khong bang nhau" & Chr(13) & Wb.Sheets(s1).Range(s4).Columns.Count & " - " & cCol
        Set Wb = Nothing
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        ActiveSheet.Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        Set Sh = ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
        Sh.Cells.Clear
        Sh.UsedRange.Rows.RowHeight = Rng.Rows(1).RowHeight
        Wb.Sheets(s1).Range(s2).Copy Sh.Range("A1")
        Sh.Range("A1").Resize(, cCol).HorizontalAlignment = xlCenterAcrossSelection
        cRow = Wb.Sheets(s3).Range(s4).Rows.Count
        k = Wb.Sheets(s3).Range(s4).Row
        Rng.Copy Sh.Range("A3").Offset(cRow - 1)
        hang = 3 + cRow + Int(Rng.Rows.Count / Lap) * Lap + IIf(Rng.Rows.Count Mod Lap = 0, -Lap, 0)
        For i = hang To (3 + cRow) Step -Lap
            Sh.Rows((i - 1) & ":" & (i + cRow - 2)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            Wb.Sheets(s3).Range(s4).Copy Sh.Range("A" & (i - 1))
            For j = 1 To cRow
                Sh.Rows(i + j - 2 & ":" & i + j - 2).RowHeight = Wb.Sheets(s3).Rows(k + j - 1 & ":" & k + j - 1).RowHeight
            Next j
        Next
        Set Wb = Nothing
        Set Sh = Nothing
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    Unload Me
End Sub

Dear ad
Em đã test với bảng lương tiêu đề nhiều hàng, và test cho lập lại 80 người. Đúng như ad nói là chậm hơn 1 tí. Nhưng tạm thời giải quyết dc vấn đề. Dù gì nó cũng nhanh hơn khi phải copy cho từng người. Em cảm ơn ad nhiều

 

[langtu020690]

Nhờ anh admin GiaiPhap giúp e cái này, lúc trước code lập lại tieu đề của em nó vẫn đang hoạt động bình thường, nhưng lần này em có 1 file lương (cấu trúc na ná lần trước), e đã thao tác nhưng tiêu đề vẫn không có lập lại, do trình em chưa tới nên không biết sai chỗ nào, e lại post lên đây nhờ admin giúp em với
+ File lập lai tiêu đề là file add-in có code
+ File test là file e cần tiêu đề lập lại, có 3 sheet, hỏng có sheet nào lập được hết. E thử tạo dữ liệu thô thì nó lập được, nhưng dùng dữ liệu của file test này thì lại không được.

 

[langtu020690]

@giaiphap nhờ xem giúp em với