Cần giúp đỡ về phần dãn dòng khi Merge dòng! (1 người xem)

Elx Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
vova2209

vova2209

Thành viên tích cực
Tham gia
5/4/17
Bài viết
835
Được thích
112
Giới tính
Nam
Nghề nghiệp
Đường bộ
Có vài bài nói về tự động điều chỉnh dòng nhưng không đúng như ý em muốn thực hiện nên nhờ các bác giúp đỡ:
khi "Wrap Text" ở 1 ô khi chữ dài ra sẽ tự dãn dòng, ít thì sẽ co lại vừa dòng. Nhưng khi Merge nhiều ô thì "Wrap Text" lại không không tự động co dãn dòng. Nhờ các bác viết cho 1 code tự động chạy co dãn dòng khi vùng link vlookup đó thay đổi, chiều rộng khi co dòng tối thiểu là 18..
File đính kèm dưới:
Em xin chân thành cảm ơn!
 

File đính kèm

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
PacificPR đã viết:
Bạn tham khảo tại Topic này: http://www.giaiphapexcel.com/diendan/threads/nhờ-trợ-giúp-tối-ưu-hóa-code-fix-chiều-cao-dòng-những-ô-được-gộp-trong-excel.124246/#post-777350
Hoặc bạn xem file (Code trong file mình sưu tầm được trên diễn đàn và mình đang dùng Code này cho BBNT)
Nhấp chuột vào đây để mở rộng...
Em chỉ muốn fix cho 1 số dòng chỉ định thôi ạ! và chiều rộng fix tối thiểu là 18!
 
Upvote 0
Upvote 0
Có vài bài nói về tự động điều chỉnh dòng nhưng không đúng như ý em muốn thực hiện nên nhờ các bác giúp đỡ:
khi "Wrap Text" ở 1 ô khi chữ dài ra sẽ tự dãn dòng, ít thì sẽ co lại vừa dòng. Nhưng khi Merge nhiều ô thì "Wrap Text" lại không không tự động co dãn dòng. Nhờ các bác viết cho 1 code tự động chạy co dãn dòng khi vùng link vlookup đó thay đổi, chiều rộng khi co dòng tối thiểu là 18..
File đính kèm dưới:
Em xin chân thành cảm ơn!
 
Upvote 0
PacificPR đã viết:
Bạn tham khảo tại Topic này: http://www.giaiphapexcel.com/diendan/threads/nhờ-trợ-giúp-tối-ưu-hóa-code-fix-chiều-cao-dòng-những-ô-được-gộp-trong-excel.124246/#post-777350
Hoặc bạn xem file (Code trong file mình sưu tầm được trên diễn đàn và mình đang dùng Code này cho BBNT)
Nhấp chuột vào đây để mở rộng...
Sub này dán làm như nào bạn ơi: Sub Spinner1_Change()
add cho chạy như nào sao mình coppy code sang file khác lại không được!
 
Upvote 0
vova2209 đã viết:
Sub này dán làm như nào bạn ơi: Sub Spinner1_Change()
add cho chạy như nào sao mình coppy code sang file khác lại không được!
Nhấp chuột vào đây để mở rộng...
Cái Code đó là khi nào gặp ô chỉ định là MergeCells thì tiến hành căn chỉnh ô đó. Mình hay kết hợp nó Code in hoặc xuất ra file Pdf.( Nếu dòng BBNT thu giống như BBNTNB thì chỉ cần Fix tại BBNTNB, tại BBNT cách gán chiều cao dòng thì sẽ nhanh hơn)
 
Upvote 0
PacificPR đã viết:
Cái Code đó là khi nào gặp ô chỉ định là MergeCells thì tiến hành căn chỉnh ô đó. Mình hay kết hợp nó Code in hoặc xuất ra file Pdf.( Nếu dòng BBNT thu giống như BBNTNB thì chỉ cần Fix tại BBNTNB, tại BBNT cách gán chiều cao dòng thì sẽ nhanh hơn)
Nhấp chuột vào đây để mở rộng...
mình copy code sang file khác không chạy được là sao nhỉ
 
Upvote 0
PacificPR đã viết:
Bạn để ý chỗ mầu đỏ là ô cần căn chỉnh và copy cái Sub MergeCellFit vào file mới nữa
If Cells(15, 4).MergeCells = True Then MergeCellFit Cells(15, 4)
Nhấp chuột vào đây để mở rộng...
hóa ra bạn gán code vào nút lên xuống, chiều rộng dòng bé quá, mình sài font chữ 13 hơi bị hẹp 1 chút chỉnh code như nào bạn nhỉ
 
Lần chỉnh sửa cuối:
Upvote 0
PacificPR đã viết:
Cái Code đó là khi nào gặp ô chỉ định là MergeCells thì tiến hành căn chỉnh ô đó. Mình hay kết hợp nó Code in hoặc xuất ra file Pdf.( Nếu dòng BBNT thu giống như BBNTNB thì chỉ cần Fix tại BBNTNB, tại BBNT cách gán chiều cao dòng thì sẽ nhanh hơn)
Nhấp chuột vào đây để mở rộng...
code như nào bạn nhỉ: dòng giống nhau thì chèn thêm dòng trống là okje! cho mình xin code, và code code in hoặc xuất file PDF nhé. hữu dụng thật!
 
Upvote 0
Hình như cái file của bạn bị vấn đề gì thì phải. Mình Copy ra file mới chạy ầm ầm. Còn file cũ phải quay 1 lúc mới xong
Bạn dùng thử cái Code này ( nó không nhanh bằng code của anh Langtuchungtinh360 nhưng cũng tạm ổn)
Mã: 
Sub FixRow(ByVal Rng As Range)
    Dim Ws As Worksheet
    Dim row As Range, cell As Range, MrgeWdth As Single
    Dim WithCellPaste As Long, ColPaste As Long, RowPaste As Long, CellPaste As Range, Diff As Single
        On Error Resume Next
    Application.ScreenUpdating = False
    Diff = 0.75
    Set Ws = Rng.Worksheet
    ColPaste = Ws.UsedRange.Columns.Count + 1
    For Each row In Rng
        If row <> Empty Then
            Set ma = row.MergeArea
            For Each cell In ma
                MrgeWdth = MrgeWdth + cell.ColumnWidth + Diff
            Next cell
            ma.RowHeight = 16.5
            RowPaste = ma.row
            Set CellPaste = Cells(RowPaste, ColPaste)
            WithCellPaste = CellPaste.ColumnWidth
            CellPaste.ColumnWidth = MrgeWdth
            CellPaste = ma.Value
            CellPaste.Font.Size = ma.Font.Size
            If ma.Font.Bold = True Then CellPaste.Font.Bold = True
            If ma.Font.Italic = True Then CellPaste.Font.Italic = True
            If ma.Font.Underline = xlUnderlineStyleSingle Then CellPaste.Font.Underline = xlUnderlineStyleSingle
            CellPaste.WrapText = True
            CellPaste.EntireRow.AutoFit
            ma.RowHeight = CellPaste.RowHeight + 16.5 / 5
            CellPaste.Clear
            CellPaste.ColumnWidth = WithCellPaste
        End If
    Next row
    Application.ScreenUpdating = True
End Sub
Mã: 
Sub RunFixRow()
Application.ScreenUpdating = False
FixRow Sheets("BBan").Range("D14")
FixRow Sheets("BBan").Range("F45:F50")
FixRow Sheets("BBan").Range("E77")
FixRow Sheets("BBan").Range("D107")
FixRow Sheets("BBan").Range("F141:F145")
Application.ScreenUpdating = True
End Sub
 

File đính kèm

Upvote 0
PacificPR đã viết:
Hình như cái file của bạn bị vấn đề gì thì phải. Mình Copy ra file mới chạy ầm ầm. Còn file cũ phải quay 1 lúc mới xong
Bạn dùng thử cái Code này ( nó không nhanh bằng code của anh Langtuchungtinh360 nhưng cũng tạm ổn)
Mã: 
Sub FixRow(ByVal Rng As Range)
    Dim Ws As Worksheet
    Dim row As Range, cell As Range, MrgeWdth As Single
    Dim WithCellPaste As Long, ColPaste As Long, RowPaste As Long, CellPaste As Range, Diff As Single
        On Error Resume Next
    Application.ScreenUpdating = False
    Diff = 0.75
    Set Ws = Rng.Worksheet
    ColPaste = Ws.UsedRange.Columns.Count + 1
    For Each row In Rng
        If row <> Empty Then
            Set ma = row.MergeArea
            For Each cell In ma
                MrgeWdth = MrgeWdth + cell.ColumnWidth + Diff
            Next cell
            ma.RowHeight = 16.5
            RowPaste = ma.row
            Set CellPaste = Cells(RowPaste, ColPaste)
            WithCellPaste = CellPaste.ColumnWidth
            CellPaste.ColumnWidth = MrgeWdth
            CellPaste = ma.Value
            CellPaste.Font.Size = ma.Font.Size
            If ma.Font.Bold = True Then CellPaste.Font.Bold = True
            If ma.Font.Italic = True Then CellPaste.Font.Italic = True
            If ma.Font.Underline = xlUnderlineStyleSingle Then CellPaste.Font.Underline = xlUnderlineStyleSingle
            CellPaste.WrapText = True
            CellPaste.EntireRow.AutoFit
            ma.RowHeight = CellPaste.RowHeight + 16.5 / 5
            CellPaste.Clear
            CellPaste.ColumnWidth = WithCellPaste
        End If
    Next row
    Application.ScreenUpdating = True
End Sub
Mã: 
Sub RunFixRow()
Application.ScreenUpdating = False
FixRow Sheets("BBan").Range("D14")
FixRow Sheets("BBan").Range("F45:F50")
FixRow Sheets("BBan").Range("E77")
FixRow Sheets("BBan").Range("D107")
FixRow Sheets("BBan").Range("F141:F145")
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh nhiều! để em test
 
Upvote 0
PacificPR đã viết:
Hình như cái file của bạn bị vấn đề gì thì phải. Mình Copy ra file mới chạy ầm ầm. Còn file cũ phải quay 1 lúc mới xong
Bạn dùng thử cái Code này ( nó không nhanh bằng code của anh Langtuchungtinh360 nhưng cũng tạm ổn)
Mã: 
Sub FixRow(ByVal Rng As Range)
    Dim Ws As Worksheet
    Dim row As Range, cell As Range, MrgeWdth As Single
    Dim WithCellPaste As Long, ColPaste As Long, RowPaste As Long, CellPaste As Range, Diff As Single
        On Error Resume Next
    Application.ScreenUpdating = False
    Diff = 0.75
    Set Ws = Rng.Worksheet
    ColPaste = Ws.UsedRange.Columns.Count + 1
    For Each row In Rng
        If row <> Empty Then
            Set ma = row.MergeArea
            For Each cell In ma
                MrgeWdth = MrgeWdth + cell.ColumnWidth + Diff
            Next cell
            ma.RowHeight = 16.5
            RowPaste = ma.row
            Set CellPaste = Cells(RowPaste, ColPaste)
            WithCellPaste = CellPaste.ColumnWidth
            CellPaste.ColumnWidth = MrgeWdth
            CellPaste = ma.Value
            CellPaste.Font.Size = ma.Font.Size
            If ma.Font.Bold = True Then CellPaste.Font.Bold = True
            If ma.Font.Italic = True Then CellPaste.Font.Italic = True
            If ma.Font.Underline = xlUnderlineStyleSingle Then CellPaste.Font.Underline = xlUnderlineStyleSingle
            CellPaste.WrapText = True
            CellPaste.EntireRow.AutoFit
            ma.RowHeight = CellPaste.RowHeight + 16.5 / 5
            CellPaste.Clear
            CellPaste.ColumnWidth = WithCellPaste
        End If
    Next row
    Application.ScreenUpdating = True
End Sub
Mã: 
Sub RunFixRow()
Application.ScreenUpdating = False
FixRow Sheets("BBan").Range("D14")
FixRow Sheets("BBan").Range("F45:F50")
FixRow Sheets("BBan").Range("E77")
FixRow Sheets("BBan").Range("D107")
FixRow Sheets("BBan").Range("F141:F145")
Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
ừ! đúng rồi file của em có vấn đề..sửa cho em code phần xuất FDF có chức năng chọn xuất từ đâu đến đâu, hoặc có cách nào in 1 lần tất cả các file pdf riêng không?
 
Upvote 0
Bạn xem file đính kèm ( Khi xuất xong bạn dùng Phần mền Foxit PhantomPDF hoặc phần mền khác nối file Pdf lại với nhau thành 1 file xong đó in là được)
 

File đính kèm

Upvote 0
PacificPR đã viết:
Bạn xem file đính kèm ( Khi xuất xong bạn dùng Phần mền Foxit PhantomPDF hoặc phần mền khác nối file Pdf lại với nhau thành 1 file xong đó in là được)
Nhấp chuột vào đây để mở rộng...
Lỗi Run-time error '-2147024773 (8007007b)': Document saved
anh xem lại dùm em với! mà file kia a saver as save sang 2003 à, a dùng office phiên bản bao nhiêu ạ!
 
Upvote 0
PacificPR đã viết:
À sai tại chỗ lấy số biên bản. Bạn xem File thử xem
Nhấp chuột vào đây để mở rộng...
chạy nuột rồi anh! file của em giờ đang nhiều sheet links với nhau. Không hiểu lỗi gì lại làm chậm file đến vậy, file kia a làm như nào mà chạy lại nhanh vậy, sv sang 2003 à hay làm như nào?
 
Upvote 0
Mình Copy sang file mới thôi. Bạn lập lại file khác đi ( Chắc file cũ lỗi gì đó). File của mình gần 40 Sheet mà cũng không chậm đến vậy
 
Upvote 0
PacificPR đã viết:
Mình Copy sang file mới thôi. Bạn lập lại file khác đi ( Chắc file cũ lỗi gì đó). File của mình gần 40 Sheet mà cũng không chậm đến vậy
Nhấp chuột vào đây để mở rộng...
Chết dở file của em cũng gần 40 sheet file toàn link hết giờ mà lập lại cũng chết dở! vâng để em thử lại
 
Upvote 0
Làm lại cho nó hoành tráng. Đối với file kiểu như hồ sơ QLCL tốt nhất là dùng VBA để cho file nó nhẹ đị cùng lắm mới sử dụng công thức thôi
Làm thêm cái Ribbon

nữa cho đẹp
 
Lần chỉnh sửa cuối:
Upvote 0
PacificPR đã viết:
Làm lại cho nó hoành tráng. Đối với file kiểu như hồ sơ QLCL tốt nhất là dùng VBA để cho file nó nhẹ đị cùng lắm mới sử dụng công thức thôi
Nhấp chuột vào đây để mở rộng...
Vâng! của em vẫn nhiều công thức update dần bỏ hết công thức đi, file của em 2,5 mb nặng quá! mà có đúng 30 sheet
 
Upvote 0

File đính kèm

Upvote 0
Để em up file tổng của em lên anh saver as lại thử xem có được không anh nhé!
 
Upvote 0
PacificPR đã viết:
Để mai mình thử xem
Nhấp chuột vào đây để mở rộng...
Đã tìm ra lỗi tại sao code chạy chậm thế, trong file của em có 3 nguyên nhân dẫn tới code chậm
Chú ý:
1. Không được để chế độ "Page Break Preview" sẽ ảnh hưởng tới tốc độ code "fixRow"
3. Không soi trang trước khi dùng code
2. Không được vlookup ảnh
------------------------------------------------
Code xuất ra PDF có cải thiện được tốc độ không anh nhỉ, em thấy chậm quá!
 
Lần chỉnh sửa cuối:
Upvote 0
PacificPR đã viết:
Mình Copy sang file mới thôi. Bạn lập lại file khác đi ( Chắc file cũ lỗi gì đó). File của mình gần 40 Sheet mà cũng không chậm đến vậy
Nhấp chuột vào đây để mở rộng...
anh ơi! em cải thiện thêm được tốc độ fix rồi ^^!
vova2209 đã viết:
Sub RunFixRow()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False

FixRow Sheets("BBan").Range("D14") 'NT Noi Bo
FixRow Sheets("BBan").Range("F45:F49")

FixRow Sheets("BBan").Range("E76") 'Phieu Yeu Cau

FixRow Sheets("BBan").Range("D105") 'NT CVXD
FixRow Sheets("BBan").Range("F139:F143")

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub


Sub FixRow(ByVal Rng As Range)
Dim Ws As Worksheet
Dim row As Range, cell As Range, MrgeWdth As Single
Dim WithCellPaste As Long, ColPaste As Long, RowPaste As Long, CellPaste As Range, Diff As Single
On Error Resume Next

Diff = 0.75
Set Ws = Rng.Worksheet
ColPaste = Ws.UsedRange.Columns.Count + 1
For Each row In Rng
If row <> Empty Then
Set ma = row.MergeArea
For Each cell In ma
MrgeWdth = MrgeWdth + cell.ColumnWidth + Diff
Next cell
ma.RowHeight = 16.5
RowPaste = ma.row
Set CellPaste = Cells(RowPaste, ColPaste)
WithCellPaste = CellPaste.ColumnWidth
CellPaste.ColumnWidth = MrgeWdth
CellPaste = ma.Value
CellPaste.Font.Size = ma.Font.Size
If ma.Font.Bold = True Then CellPaste.Font.Bold = True
If ma.Font.Italic = True Then CellPaste.Font.Italic = True
If ma.Font.Underline = xlUnderlineStyleSingle Then CellPaste.Font.Underline = xlUnderlineStyleSingle
CellPaste.WrapText = True
CellPaste.EntireRow.AutoFit
ma.RowHeight = CellPaste.RowHeight + 16.5 / 5
CellPaste.Clear
CellPaste.ColumnWidth = WithCellPaste
End If
Next row
End Sub
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
PacificPR đã viết:
Bạn thiết kế cái Ribbon như file này cho nó đẹp
Nhấp chuột vào đây để mở rộng...
bạn có cách nào tạo Ribbon hay không chỉ mình với.
chắc bạn cũng là dân làm xây dựng, vậy có thể Add friend facebook ( Văn Tân Lê, SĐT 0939795092) để bàn cách trình bày file làm hồ sơ quản lý không? hiện mình cũng đang phát triển mà lười quá. cạn kiệt ý tưởng rồi
 
Upvote 0
langtuchungtinh360 đã viết:
bạn có cách nào tạo Ribbon hay không chỉ mình với.
chắc bạn cũng là dân làm xây dựng, vậy có thể Add friend facebook để bàn cách trình bày file làm hồ sơ quản lý không? hiện mình cũng đang phát triển mà lười quá. cạn kiệt ý tưởng rồi
Nhấp chuột vào đây để mở rộng...
Ô cái đó em lấy của anh về dùng mà hì hì...:D . Em chuyển từ Sharava36 sang cái này đó. Anh làm xong file BB chưa
 
Upvote 0
PacificPR đã viết:
Ô cái đó em lấy của anh về dùng mà hì hì...:D . Em chuyển từ Sharava36 sang cái này đó. Anh làm xong file BB chưa
Nhấp chuột vào đây để mở rộng...
thế à. vẫn chưa xong, đang làm code chỉnh trang biên bản lại. cái code fixhightrow cũng trong số đó. còn code đang viết thì đang định hướng chỉnh lại bảng số liệu (ví dụ cốt thép) thì đôi khi những ô bị mercel lại nằm ngay chỗ giao giữa 2 trang nên cần kéo lề lên. tương tự chữ ký của biên bản.
 
Upvote 0
langtuchungtinh360 đã viết:
thế à. vẫn chưa xong, đang làm code chỉnh trang biên bản lại. cái code fixhightrow cũng trong số đó. còn code đang viết thì đang định hướng chỉnh lại bảng số liệu (ví dụ cốt thép) thì đôi khi những ô bị mercel lại nằm ngay chỗ giao giữa 2 trang nên cần kéo lề lên. tương tự chữ ký của biên bản.
Nhấp chuột vào đây để mở rộng...
Em thấy phần HSQLCL bên Giá xây dựng họ có phần ngắt trang anh qua đó xem thử xem. Mà kết bạn với anh thì vào đâu. Em không thấy mục này
 
Upvote 0
PacificPR đã viết:
Em thấy phần HSQLCL bên Giá xây dựng họ có phần ngắt trang anh qua đó xem thử xem. Mà kết bạn với anh thì vào đâu. Em không thấy mục này
Nhấp chuột vào đây để mở rộng...
họ giấu code hết rồi bạn, tham khảo được thì nói gì. facebook bạn là gì? nói trên face dễ hơn, thế nhé. lạc đề topic rồi.
 
Upvote 0
langtuchungtinh360 đã viết:
họ giấu code hết rồi bạn, tham khảo được thì nói gì. facebook bạn là gì? nói trên face dễ hơn, thế nhé. lạc đề topic rồi.
Nhấp chuột vào đây để mở rộng...
Hôm trước em tải về mở máy cho bẻ khóa 1 ngày không xong. Thế là thất bại chả xem được gì. Em không chơi facebook.
Thôi trả Toptic lại cho chủ của nó thôi. :D
 
Upvote 0
Bác PacificPR!
Anh ơi! sửa hộ lại em ít code với, fixrow không tự co lại dòng khi không có giữ liệu!
File đính kèm dưới
 

File đính kèm

Upvote 0
vova2209 đã viết:
Bác PacificPR!
Anh ơi! sửa hộ lại em ít code với, fixrow không tự co lại dòng khi không có giữ liệu!
File đính kèm dưới
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub FixRow(ByVal Rng As Range)
    Dim Ws As Worksheet
    Dim row As Range, cell As Range, MrgeWdth As Single
    Dim WithCellPaste As Long, ColPaste As Long, RowPaste As Long, CellPaste As Range, Diff As Single
    On Error Resume Next
    Diff = 0.75
    Set Ws = Rng.Worksheet
    ColPaste = Ws.UsedRange.Columns.Count + 1
    For Each row In Rng
        Set ma = row.MergeArea
        For Each cell In ma
            MrgeWdth = MrgeWdth + cell.ColumnWidth + Diff
        Next cell
        ma.RowHeight = 16.5
        RowPaste = ma.row
        Set CellPaste = Cells(RowPaste, ColPaste)
        WithCellPaste = CellPaste.ColumnWidth
        CellPaste.ColumnWidth = MrgeWdth
        CellPaste = ma.Value
        CellPaste.Font.Size = ma.Font.Size
        If ma.Font.Bold = True Then CellPaste.Font.Bold = True
        If ma.Font.Italic = True Then CellPaste.Font.Italic = True
        If ma.Font.Underline = xlUnderlineStyleSingle Then CellPaste.Font.Underline = xlUnderlineStyleSingle
        CellPaste.WrapText = True
        CellPaste.EntireRow.AutoFit
        ma.RowHeight = CellPaste.RowHeight + 16.5 / 5
        CellPaste.Clear
        CellPaste.ColumnWidth = WithCellPaste
    Next row
End Sub
 
Upvote 0
PacificPR đã viết:
Bạn thiết kế cái Ribbon như file này cho nó đẹp
Nhấp chuột vào đây để mở rộng...
Tôi ấn tượng với file của bạn quá. Cảm ơn bạn đã chia sẻ.
Cho tôi hỏi 1 số vấn đề là:
1. file này bạn làm trên office bao nhiêu nhỉ. Tôi dùng office 2010. Lúc mở ra nó báo lỗi. Tuy nhiên vẫn mở ra và xem được
2. Đây có phải là bản chưa đầy đủ hay sao mà khi KÍCH vào 1 số tiện ích như mục: Xuất biên bản ra Pdf, Ghi nhật ký thi công, Xuất nhật ký ra Pdf. Lúc đó lại hiện thông báo: Chua co code cho muc nay
Mong nhận được sự giúp đỡ. Xin chân thành cảm ơn !
 
Upvote 0
lenolim đã viết:
Tôi ấn tượng với file của bạn quá. Cảm ơn bạn đã chia sẻ.
Cho tôi hỏi 1 số vấn đề là:
1. file này bạn làm trên office bao nhiêu nhỉ. Tôi dùng office 2010. Lúc mở ra nó báo lỗi. Tuy nhiên vẫn mở ra và xem được
2. Đây có phải là bản chưa đầy đủ hay sao mà khi KÍCH vào 1 số tiện ích như mục: Xuất biên bản ra Pdf, Ghi nhật ký thi công, Xuất nhật ký ra Pdf. Lúc đó lại hiện thông báo: Chua co code cho muc nay
Mong nhận được sự giúp đỡ. Xin chân thành cảm ơn !
Nhấp chuột vào đây để mở rộng...
Đây là bản chưa hoàn thiện. Do độ lười dạo này hơn cao nên chưa hoàn thiện được bạn ah. Mình đang dùng ofice2016 (mà nó báo lỗi sao vậy bạn. Mình chưa Test ở máy khác nữa)
 
Upvote 0
lenolim đã viết:
Tôi ấn tượng với file của bạn quá. Cảm ơn bạn đã chia sẻ.
Cho tôi hỏi 1 số vấn đề là:
1. file này bạn làm trên office bao nhiêu nhỉ. Tôi dùng office 2010. Lúc mở ra nó báo lỗi. Tuy nhiên vẫn mở ra và xem được
2. Đây có phải là bản chưa đầy đủ hay sao mà khi KÍCH vào 1 số tiện ích như mục: Xuất biên bản ra Pdf, Ghi nhật ký thi công, Xuất nhật ký ra Pdf. Lúc đó lại hiện thông báo: Chua co code cho muc nay
Mong nhận được sự giúp đỡ. Xin chân thành cảm ơn !
Nhấp chuột vào đây để mở rộng...
ấn alt+f8, hoặc ad code vào 1 hình ảnh nào đấy dùng!
 
Upvote 0
PacificPR đã viết:
Mã: 
Sub FixRow(ByVal Rng As Range)
    Dim Ws As Worksheet
    Dim row As Range, cell As Range, MrgeWdth As Single
    Dim WithCellPaste As Long, ColPaste As Long, RowPaste As Long, CellPaste As Range, Diff As Single
    On Error Resume Next
    Diff = 0.75
    Set Ws = Rng.Worksheet
    ColPaste = Ws.UsedRange.Columns.Count + 1
    For Each row In Rng
        Set ma = row.MergeArea
        For Each cell In ma
            MrgeWdth = MrgeWdth + cell.ColumnWidth + Diff
        Next cell
        ma.RowHeight = 16.5
        RowPaste = ma.row
        Set CellPaste = Cells(RowPaste, ColPaste)
        WithCellPaste = CellPaste.ColumnWidth
        CellPaste.ColumnWidth = MrgeWdth
        CellPaste = ma.Value
        CellPaste.Font.Size = ma.Font.Size
        If ma.Font.Bold = True Then CellPaste.Font.Bold = True
        If ma.Font.Italic = True Then CellPaste.Font.Italic = True
        If ma.Font.Underline = xlUnderlineStyleSingle Then CellPaste.Font.Underline = xlUnderlineStyleSingle
        CellPaste.WrapText = True
        CellPaste.EntireRow.AutoFit
        ma.RowHeight = CellPaste.RowHeight + 16.5 / 5
        CellPaste.Clear
        CellPaste.ColumnWidth = WithCellPaste
    Next row
End Sub
Nhấp chuột vào đây để mở rộng...
Anh ơi! code chạy ngon rồi ạ!
vùng giữ liệu có lấy được tự đông những dòng Merge không anh?
 
Lần chỉnh sửa cuối:
Upvote 0
vova2209 đã viết:
Anh ơi! code chạy ngon rồi ạ!
vùng giữ liệu có lấy được tự đông những dòng Merge không anh?
Nhấp chuột vào đây để mở rộng...
Chắc là do mấy cái dòng này
Mã: 
Application.ScreenUpdating
    Application.Calculation
    Application.DisplayAlerts
    Application.EnableEvents
bạn bỏ nó đi. Xuất tự động thì cứ để cho nó làm Tắt mở làm chi
 
Upvote 0
PacificPR đã viết:
Đây là bản chưa hoàn thiện. Do độ lười dạo này hơn cao nên chưa hoàn thiện được bạn ah. Mình đang dùng ofice2016 (mà nó báo lỗi sao vậy bạn. Mình chưa Test ở máy khác nữa)
Nhấp chuột vào đây để mở rộng...
Excel nó báo. không thể đọc được file này. Chắc là do phiên bản office của tôi cũ hơn thôi.
Hóng ! được xem bản hoàn thiện của PacificPR
Chúc sức khỏe để hoàn thiện nhé ./.
 
Upvote 0
PacificPR đã viết:
Chắc là do mấy cái dòng này
Mã: 
Application.ScreenUpdating
    Application.Calculation
    Application.DisplayAlerts
    Application.EnableEvents
bạn bỏ nó đi. Xuất tự động thì cứ để cho nó làm Tắt mở làm chi
Nhấp chuột vào đây để mở rộng...
đúng rồi anh à! em bỏ đi chạy ngon rồi, cảm ơn anh ạ
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi (5 người xem)
Trả lời
1
Đọc
14
Maika8008
Maika8008
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube (1 người xem)
    • Thích
    • Yêu thích
Trả lời
13
Đọc
1K
Gà Con yêu VBA
Gà Con yêu VBA
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
55
Đọc
22K
Gà Con yêu VBA
Gà Con yêu VBA
C
Fix lỗi Application.InputBox Type:=8 (1 người xem)
    • Cười
Trả lời
20
Đọc
535
cdshtz88
C
ptm0412
Quá tin tưởng vào AI các thể loại (2 người xem)
    • Cười
Trả lời
4
Đọc
136
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code (1 người xem)
Trả lời
6
Đọc
88
ptm0412
ptm0412
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
5
Đọc
368
SA_DQ
SA_DQ
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
281
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
250
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (2 người xem)
    • Thích
Trả lời
0
Đọc
669
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
105
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
288
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
677
nghiabros
N
L
Nhờ hỗ trợ tìm hàm excel trả về giá trị
Trả lời
4
Đọc
118
lechuong174
L
SA_DQ
Copilot & giúp hỗ trợ nhập các ký tự đặt biệt
    • Thích
Trả lời
0
Đọc
79
SA_DQ
SA_DQ
GPE-Trợ Lý
[GPE20] BIỂU ĐỒ CHUYÊN NGHIỆP: PHÁ VỠ GIỚI HẠN 2 TRỤC CỦA EXCEL
    • Thích
    • Yêu thích
Trả lời
1
Đọc
4K
GPE-Trợ Lý
GPE-Trợ Lý
hadu8889
EXCEL TỰ ĐỘNG ĐÓNG KHI SỬA TEXT Ở TRÊN USERFORM
Trả lời
10
Đọc
248
LOGANWover
L
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
565
Đọc
78K
lacmatquan
L
H
Lấy giá trị format trong ô của excel
Trả lời
2
Đọc
170
LOGANWover
L
A
Tìm nơi học VBA uy tín
    • Cười
Trả lời
2
Đọc
159
SA_DQ
SA_DQ
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom