Tính độ rộng tông các cột hay hàng

Liên hệ QC
HeSanbi đã viết:
Bạn thử thực hiện thế này xem sao:
---------
PHP: 
Public Sub Test()
  Dim Tmp!, TiLe!, Characters!, Points!
  '---------------------------------'
  Application.ScreenUpdating = False
  Tmp = Columns(1).ColumnWidth
  Columns(1).ColumnWidth = 10
  TiLe = Columns(1).Width / 9 - 1
  Columns(1).ColumnWidth = Tmp
  Application.ScreenUpdating = True
  '---------------------------------'
  Characters = 10
  Points = (Characters - 1) * TiLe + 9
  Characters = (Points - 9) / TiLe + 1
  Debug.Print TiLe, Points, Characters
  Points = [A1:C1].EntireColumn.Width
  [D1].EntireColumn.ColumnWidth = (Points - 9) / TiLe + 1
End Sub
Nhấp chuột vào đây để mở rộng...
Anh cho em hỏi: dùng Code thế nào anh?
 
quanglenb đã viết:
Cám ơn anh, anh cho em hỏi:
Cách sử dụng sao ạ?
Vùng [A1:C1] mình đo được đơn vị là pt
Thì chạy code ở ô D1 là picas đúng không ạ?
Nhưng em chạy code thấy không hiện dữ liệu ạ!
Cảm ơn anh!
Nhấp chuột vào đây để mở rộng...
chothadiem đã viết:
Anh cho em hỏi: dùng Code thế nào anh?
Nhấp chuột vào đây để mở rộng...

Không biết các bạn định vận dụng vấn đề gì.
Code này chỉ là code tạm, chứ ngâm cứu kỉ rất mất thời gian, và công sức.

PHP: 
Public Sub TestArea()
  ' Height Point'
  [A1] = RangeHeight([A1:D10], True)
  ' Height Character'
  [A2] = RangeHeight([A1:D10], False)
  ' Width Point'
  [A3] = RangeWidth([A1:D10], True)
  ' Width Character'
  [A4] = RangeWidth([A1:D10], False)
  '[A5:A15].EntireRow.RowHeight = 100 / [A5:A15].Rows.Count'
  '[E1:F1].EntireColumn.ColumnWidth = 100 / [E1:F1].Columns.Count'
  'Không thể áp dụng trực tiếp hàm vào Cell excel'
End Sub
Private Function RangeHeight!(ByVal Rng As Range, Optional ByVal IsPoints As Boolean = True)
  RangeHeight = Rng.EntireColumn.Width
  If Not IsPoints Then
    RangeHeight = PointToCharacter(RangeHeight)
  End If
End Function
Public Function RangeWidth!(ByVal Rng As Range, Optional ByVal IsPoints As Boolean = True)
  If IsPoints Then
    RangeWidth = Rng.EntireColumn.Width
  Else
    Dim I&
    For I = 1 To Rng.Columns.Count
      RangeWidth = RangeWidth + Rng(1, I).EntireColumn.ColumnWidth
    Next I
  End If
End Function

Private Function CharacterToPoint(ByVal Characters!)
  If VBA.Abs(Characters) - 1 <= 0 Then Exit Function
  Dim Tmp!, TiLe!, Points!
  '---------------------------------'
  Application.ScreenUpdating = False
  Tmp = Columns(1).ColumnWidth
  Columns(1).ColumnWidth = 10
  TiLe = Columns(1).Width / 9 - 1
  Columns(1).ColumnWidth = Tmp
  Application.ScreenUpdating = True
  '---------------------------------'
  CharacterToPoint = (VBA.Abs(Characters) - 1) * TiLe + 9
End Function
Private Function PointToCharacter(ByVal Points!)
  If VBA.Abs(Points) - 9 <= 0 Then Exit Function
  Dim Tmp!, TiLe!, Characters!
  '---------------------------------'
  Application.ScreenUpdating = False
  Tmp = Columns(1).ColumnWidth
  Columns(1).ColumnWidth = 10
  TiLe = Columns(1).Width / 9 - 1
  Columns(1).ColumnWidth = Tmp
  Application.ScreenUpdating = True
  '---------------------------------'
  PointToCharacter = (VBA.Abs(Points) - 9) / TiLe + 1
End Function
 
HeSanbi đã viết:
Không biết các bạn định vận dụng vấn đề gì.
Code này chỉ là code tạm, chứ ngâm cứu kỉ rất mất thời gian, và công sức.

PHP: 
Public Sub TestArea()
  ' Height Point'
  [A1] = RangeHeight([A1:D10], True)
  ' Height Character'
  [A2] = RangeHeight([A1:D10], False)
  ' Width Point'
  [A3] = RangeWidth([A1:D10], True)
  ' Width Character'
  [A4] = RangeWidth([A1:D10], False)
  '[A5:A15].EntireRow.RowHeight = 100 / [A5:A15].Rows.Count'
  '[E1:F1].EntireColumn.ColumnWidth = 100 / [E1:F1].Columns.Count'
  'Không thể áp dụng trực tiếp hàm vào Cell excel'
End Sub
Private Function RangeHeight!(ByVal Rng As Range, Optional ByVal IsPoints As Boolean = True)
  RangeHeight = Rng.EntireColumn.Width
  If Not IsPoints Then
    RangeHeight = PointToCharacter(RangeHeight)
  End If
End Function
Public Function RangeWidth!(ByVal Rng As Range, Optional ByVal IsPoints As Boolean = True)
  If IsPoints Then
    RangeWidth = Rng.EntireColumn.Width
  Else
    Dim I&
    For I = 1 To Rng.Columns.Count
      RangeWidth = RangeWidth + Rng(1, I).EntireColumn.ColumnWidth
    Next I
  End If
End Function

Private Function CharacterToPoint(ByVal Characters!)
  If VBA.Abs(Characters) - 1 <= 0 Then Exit Function
  Dim Tmp!, TiLe!, Points!
  '---------------------------------'
  Application.ScreenUpdating = False
  Tmp = Columns(1).ColumnWidth
  Columns(1).ColumnWidth = 10
  TiLe = Columns(1).Width / 9 - 1
  Columns(1).ColumnWidth = Tmp
  Application.ScreenUpdating = True
  '---------------------------------'
  CharacterToPoint = (VBA.Abs(Characters) - 1) * TiLe + 9
End Function
Private Function PointToCharacter(ByVal Points!)
  If VBA.Abs(Points) - 9 <= 0 Then Exit Function
  Dim Tmp!, TiLe!, Characters!
  '---------------------------------'
  Application.ScreenUpdating = False
  Tmp = Columns(1).ColumnWidth
  Columns(1).ColumnWidth = 10
  TiLe = Columns(1).Width / 9 - 1
  Columns(1).ColumnWidth = Tmp
  Application.ScreenUpdating = True
  '---------------------------------'
  PointToCharacter = (VBA.Abs(Points) - 9) / TiLe + 1
End Function
Nhấp chuột vào đây để mở rộng...
Em có áp dụng hàm để tính độ rộng cột và độ cao hàng của anh giúp trên!
Sau khi ra độ rộng của hàng của một vùng nào đó C1:C10, độ rộng tính bằng pt được điền kết quả vào ô D1, giờ em muốn đổi dữ liệu ô D1 từ đơn vị pt ra pica và điền kết quả tính ra pica vào ô nào đó do mình chọn.
Anh có nói "Code này chỉ là code tạm" là sao ạ? vận dụng code anh giúp trên thế nào vào trường hợp em nêu trong bài này ạ!
Cảm ơn anh nhiều!
 
HeSanbi đã viết:
Không biết các bạn định vận dụng vấn đề gì.
Code này chỉ là code tạm, chứ ngâm cứu kỉ rất mất thời gian, và công sức.

PHP: 
Public Sub TestArea()
  ' Height Point'
  [A1] = RangeHeight([A1:D10], True)
  ' Height Character'
  [A2] = RangeHeight([A1:D10], False)
  ' Width Point'
  [A3] = RangeWidth([A1:D10], True)
  ' Width Character'
  [A4] = RangeWidth([A1:D10], False)
  '[A5:A15].EntireRow.RowHeight = 100 / [A5:A15].Rows.Count'
  '[E1:F1].EntireColumn.ColumnWidth = 100 / [E1:F1].Columns.Count'
  'Không thể áp dụng trực tiếp hàm vào Cell excel'
End Sub
Private Function RangeHeight!(ByVal Rng As Range, Optional ByVal IsPoints As Boolean = True)
  RangeHeight = Rng.EntireColumn.Width
  If Not IsPoints Then
    RangeHeight = PointToCharacter(RangeHeight)
  End If
End Function
Public Function RangeWidth!(ByVal Rng As Range, Optional ByVal IsPoints As Boolean = True)
  If IsPoints Then
    RangeWidth = Rng.EntireColumn.Width
  Else
    Dim I&
    For I = 1 To Rng.Columns.Count
      RangeWidth = RangeWidth + Rng(1, I).EntireColumn.ColumnWidth
    Next I
  End If
End Function

Private Function CharacterToPoint(ByVal Characters!)
  If VBA.Abs(Characters) - 1 <= 0 Then Exit Function
  Dim Tmp!, TiLe!, Points!
  '---------------------------------'
  Application.ScreenUpdating = False
  Tmp = Columns(1).ColumnWidth
  Columns(1).ColumnWidth = 10
  TiLe = Columns(1).Width / 9 - 1
  Columns(1).ColumnWidth = Tmp
  Application.ScreenUpdating = True
  '---------------------------------'
  CharacterToPoint = (VBA.Abs(Characters) - 1) * TiLe + 9
End Function
Private Function PointToCharacter(ByVal Points!)
  If VBA.Abs(Points) - 9 <= 0 Then Exit Function
  Dim Tmp!, TiLe!, Characters!
  '---------------------------------'
  Application.ScreenUpdating = False
  Tmp = Columns(1).ColumnWidth
  Columns(1).ColumnWidth = 10
  TiLe = Columns(1).Width / 9 - 1
  Columns(1).ColumnWidth = Tmp
  Application.ScreenUpdating = True
  '---------------------------------'
  PointToCharacter = (VBA.Abs(Points) - 9) / TiLe + 1
End Function
Nhấp chuột vào đây để mở rộng...
Mình không nghĩ nó phức tạp vậy!
Cảm ơn bạn, nhờ bạn mà mình đã hiểu rõ hơn!
Nếu có thời gian bạn giúp cách quy đổi ra đơn vị pica từ pt mới nhé!
Mình cũng đang rất cần.
 
chothadiem đã viết:
Em có áp dụng hàm để tính độ rộng cột và độ cao hàng của anh giúp trên!
Sau khi ra độ rộng của hàng của một vùng nào đó C1:C10, độ rộng tính bằng pt được điền kết quả vào ô D1, giờ em muốn đổi dữ liệu ô D1 từ đơn vị pt ra pica và điền kết quả tính ra pica vào ô nào đó do mình chọn.
Anh có nói "Code này chỉ là code tạm" là sao ạ? vận dụng code anh giúp trên thế nào vào trường hợp em nêu trong bài này ạ!
Cảm ơn anh nhiều!
Nhấp chuột vào đây để mở rộng...
Tôi không thể hỗ trợ bạn được thêm nữa vì vấn đề này là vấn đề chuyên sâu.
Bạn cần phải biết VBA.

"Code này chỉ là code tạm"

Vì khi lấy tỉ lệ Phông chữ tôi đã mượn giá trị độ rộng 10 của cột để tính, mà không dùng kĩ thuật hay giải thuật.

Bạn phải lấy tỉ lệ độ rộng này từ trong Font ở System Window bằng các hàm API, nhưng bạn không biết VBA làm sao làm đây.

Vì sao cần làm như vậy, vì nếu Sheet được định dạng ở Dạng phông và kích thước khác nhau thì tỉ lệ sẽ thay đổi theo phông.

-------------------------------------------

Trừ khi Trang tính của bạn Luôn luôn được định dạng ở một Font cố định
Ví dụ: Phông .VNArial và Size là 10 thì tỉ lệ này sẽ bằng 5.25, có rất nhiều phông có tỉ lệ này.

Nếu như vậy Trên hàm tôi viết ở trên bạn chỉ cần thay TiLe = 5.25, và xóa những dòng trong '-------------' đi.

Xóa toàn bộ đoạn:
'---------------------------------'
Application.ScreenUpdating = False
Tmp = Columns(1).ColumnWidth
Columns(1).ColumnWidth = 10
TiLe = Columns(1).Width / 9 - 1
Columns(1).ColumnWidth = Tmp
Application.ScreenUpdating = True
'---------------------------------'
Sửa thành:
TiLe = 5.25

Và sửa Private thành Public, và vận dụng trực tiếp vào cell Excel

Để biết và lấy tỉ lệ phông chữ:
PHP: 
Private Sub KiemTraTiLePhongChu()
  Dim Tmp!, TiLe!, Characters!
  '---------------------------------'
  Application.ScreenUpdating = False
  Tmp = Columns(1).ColumnWidth
  Columns(1).ColumnWidth = 10
  Debug.Print Columns(1).Width / 9 - 1
  MsgBox Columns(1).Width / 9 - 1
  Columns(1).ColumnWidth = Tmp
  Application.ScreenUpdating = True

End Function
 
HeSanbi đã viết:
Tôi không thể hỗ trợ bạn được thêm nữa vì vấn đề này là vấn đề chuyên sâu.
Bạn cần phải biết VBA.

"Code này chỉ là code tạm"

Vì khi lấy tỉ lệ Phông chữ tôi đã mượn giá trị độ rộng 10 của cột để tính, mà không dùng kĩ thuật hay giải thuật.

Bạn phải lấy tỉ lệ độ rộng này từ trong Font ở System Window bằng các hàm API, nhưng bạn không biết VBA làm sao làm đây.

Vì sao cần làm như vậy, vì nếu Sheet được định dạng ở Dạng phông và kích thước khác nhau thì tỉ lệ sẽ thay đổi theo phông.

-------------------------------------------

Trừ khi Trang tính của bạn Luôn luôn được định dạng ở một Font cố định
Ví dụ: Phông .VNArial và Size là 10 thì tỉ lệ này sẽ bằng 5.25, có rất nhiều phông có tỉ lệ này.

Nếu như vậy Trên hàm tôi viết ở trên bạn chỉ cần thay TiLe = 5.25, và xóa những dòng trong '-------------' đi.

Xóa toàn bộ đoạn:
'---------------------------------'
Application.ScreenUpdating = False
Tmp = Columns(1).ColumnWidth
Columns(1).ColumnWidth = 10
TiLe = Columns(1).Width / 9 - 1
Columns(1).ColumnWidth = Tmp
Application.ScreenUpdating = True
'---------------------------------'
Sửa thành:
TiLe = 5.25

Và sửa Private thành Public, và vận dụng trực tiếp vào cell Excel

Để biết và lấy tỉ lệ phông chữ:
PHP: 
Private Sub KiemTraTiLePhongChu()
  Dim Tmp!, TiLe!, Characters!
  '---------------------------------'
  Application.ScreenUpdating = False
  Tmp = Columns(1).ColumnWidth
  Columns(1).ColumnWidth = 10
  Debug.Print Columns(1).Width / 9 - 1
  MsgBox Columns(1).Width / 9 - 1
  Columns(1).ColumnWidth = Tmp
  Application.ScreenUpdating = True

End Function
Nhấp chuột vào đây để mở rộng...
Dạ! cám ơn anh, phiền anh thêm chút xíu ạ!
Nhờ anh giúp duy nhất một lần nữa:
Anh có thể cho em xin thêm 2 trường hợp là Phông phổ thông để soạn thảo văn bản "Times new Roman" cỡ chữ là 13 và 14 thì đoạn code hoàn thiện để quy đổi đơn vị từ pt ra pica được không ạ?
 
chothadiem đã viết:
Dạ! cám ơn anh, phiền anh thêm chút xíu ạ!
Nhờ anh giúp duy nhất một lần nữa:
Anh có thể cho em xin thêm 2 trường hợp là Phông phổ thông để soạn thảo văn bản "Times new Roman" cỡ chữ là 13 và 14 thì đoạn code hoàn thiện để quy đổi đơn vị từ pt ra pica được không ạ?
Nhấp chuột vào đây để mở rộng...
Em cũng đang cần Phong.Times new Roman và size 13.
Nhờ anh ra tay!
 
chothadiem đã viết:
Em cứ tính bằng máy tính nên nó cứ lệch anh ạ! Không ra được một số gọi là hệ số tỷ lệ!
"sử dụng WinAPI để lấy thông số cơ sở của Window" là thế nào vậy anh?
Nhấp chuột vào đây để mở rộng...
em chạy code anh giúp để lấy độ rộng cột bằng độ rộng tổng các cột thấy báo lỗi anh ạ!
Anh xem giúp em:
Mã: 
Sub Chay
Columns("J").ColumnWidth = RangeWidth([B1: H1])
End
111.png
Bài đã được tự động gộp:

HeSanbi đã viết:
Đơn vị là Points
72 Points = 2.54 Cm
1 Points = 1/72*2.54 Cm

Cách lấy độ rộng Cột chọn:
PHP: 
Selection(1,Selection.Columns.Count).Left + Selection(1,Selection.Columns.Count).Width  - Selection(1,1).Left
Cách lấy chiều cao Hàng chọn:
PHP: 
Selection(Selection.Rows.Count, 1).Top + Selection(Selection.Rows.Count,1).Height - Selection(1,1).Top

Cách lấy độ rộng và chiều cao đã xác định:
Set RNG = [B4:C25]
Thay thế toàn bộ Selection thành RNG


Hàm (Tạo một Module và copy code dưới vào):
PHP: 
Public RSelection As Range
Function SelectionWidth() As Long
  Application.Volatile
  Dim Rng As Range
  If Not RSelection Is Nothing Then
    Set Rng = RSelection
    SelectionWidth = Rng(1, Rng.Columns.Count).Left + Rng(1, Rng.Columns.Count).Width - Rng(1, 1).Left
  End If
End Function

Function SelectionHeight() As Long
  Application.Volatile
  Dim Rng As Range
  If Not RSelection Is Nothing Then
    Set Rng = RSelection
    SelectionHeight = Rng(Rng.Rows.Count, 1).Top + Rng(Rng.Rows.Count, 1).Height - Rng(1, 1).Top
  End If
End Function
Function RangeWidth(Optional ByVal Rng As Range) As Long
  Application.Volatile
  If Rng Is Nothing Then Set Rng = RSelection
  If Rng Is Nothing Then Exit Function
  RangeWidth = Rng(1, Rng.Columns.Count).Left + Rng(1, Rng.Columns.Count).Width - Rng(1, 1).Left
End Function

Function RangeHeight(Optional ByVal Rng As Range) As Long
  Application.Volatile
  If Rng Is Nothing Then Set Rng = RSelection
  If Rng Is Nothing Then Exit Function
  RangeHeight = Rng(Rng.Rows.Count, 1).Top + Rng(Rng.Rows.Count, 1).Height - Rng(1, 1).Top
End Function

Copy đoạn này vào Code Worksheet đang thực hiện:

PHP: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Set RSelection = Target
  Application.Calculate
End Sub
Nhấp chuột vào đây để mở rộng...
Em đã Thay thế toàn bộ Selection thành RNG
và được code trong module:
Mã: 
Public RRNG As Range
Function RNGWidth() As Long
  Application.Volatile
  Dim Rng As Range
  If Not RRNG Is Nothing Then
    Set Rng = RRNG
    RNGWidth = Rng(1, Rng.Columns.Count).Left + Rng(1, Rng.Columns.Count).Width - Rng(1, 1).Left
  End If
End Function

Function RNGHeight() As Long
  Application.Volatile
  Dim Rng As Range
  If Not RRNG Is Nothing Then
    Set Rng = RRNG
    RNGHeight = Rng(Rng.Rows.Count, 1).Top + Rng(Rng.Rows.Count, 1).Height - Rng(1, 1).Top
  End If
End Function
Function RangeWidth(Optional ByVal Rng As Range) As Long
  Application.Volatile
  If Rng Is Nothing Then Set Rng = RRNG
  If Rng Is Nothing Then Exit Function
  RangeWidth = Rng(1, Rng.Columns.Count).Left + Rng(1, Rng.Columns.Count).Width - Rng(1, 1).Left
End Function

Function RangeHeight(Optional ByVal Rng As Range) As Long
  Application.Volatile
  If Rng Is Nothing Then Set Rng = RRNG
  If Rng Is Nothing Then Exit Function
  RangeHeight = Rng(Rng.Rows.Count, 1).Top + Rng(Rng.Rows.Count, 1).Height - Rng(1, 1).Top
End Function
Code trong sheet:
Mã: 
Private Sub Worksheet_RNGChange(ByVal Target As Range)
  Set RRNG = Target
  Application.Calculate
End Sub
Set RNG = [B4:C25] để lấy chiều cao là sao vậy anh?
nhờ anh chỉ bảo em thêm chút để em có thể lấy được chiểu cao của một cột theo ý muốn.
Cảm ơn anh!ok2.png
 

File đính kèm

  • ok.xlsm
    13.8 KB · Đọc: 2
Lần chỉnh sửa cuối:
HeSanbi đã viết:
Chẳng nhẽ tôi phải viết cả một bài viết để giải thích cho các bạn đây.

Cột mà khi bạn thực hiện Giãn cột: có hai thông số

Ví dụ: Cột A có thông số độ rộng là 6,33 và 64

Thì:
1. Thông số 6,33 đơn vị là Pica
2. Thông số 64 là đơn vị Pixels

Đơn vị tính trong VBA:
Range("A1").Width = 48 đơn vị là Points
hoặc Columns("A").Width = 48

Đối với Hàng:
1. Thông số 16.50 đơn vị là Points
2. Thông số 22.0 là đơn vị Pixels

Rows(1).Height = 16.50 đơn vị vẫn là Points


Để đổi đơn vị Points -> Pixels hoặc ngược lại các bạn cần sử dụng WinAPI để lấy thông số cơ sở của Window


Các bạn còn thắc mắc gì nữa không tôi giải thích luôn thể.
Bài đã được tự động gộp:


Tôi đã có hướng dẫn ở #8 rồi
Nhấp chuột vào đây để mở rộng...
Mình đã làm như #8 không có được, hay mình làm lỗi ở đoạn nào, nhờ bạn HeSanbi cụ thể hơn giúp mình để mình làm được xác định độ rộng cột nào đó bằng tổng độ rộng các cột chọn
 
Lần chỉnh sửa cuối:
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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2
Trả lời
33
Đọc
281
ptm0412
ptm0412
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
Trả lời
1
Đọc
80
Hoàng Trọng Nghĩa
Hoàng Trọng Nghĩa
trantrimmo
Xin code VBA xuất pdf từ 3 sheet theo lấy thông tin theo tên sheet ạ.
Trả lời
1
Đọc
100
dangvandang
dangvandang
B
  • Question
Chuyển đổi dữ liệu sạng dạng mảng
Trả lời
6
Đọc
108
HieuCD
H
S
Nhờ giúp đỡ code in toàn bộ danh sách có điều kiện
Trả lời
6
Đọc
150
Hoàng Tuấn 868
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom