megoldást keresek erre a problémára
-
#327
Az alábbi két makróval megadhatod mm-ben a méreteket. A makrókat nem én írtam.
Sub cmdHeight_Click()
nHeight = InputBox("Add meg a magasságot mm-ben", "Magasság", vbYesNo)
If nHeight <= 0 Then
MsgBox "A magasságnak nagyobbnak kell lennie nullánál!", vbExclamation, "Cellaméretek": Exit Sub
End If
If nHeight > 144.2 Then
MsgBox "A legnagyobb sormagasság: 144,2 mm!", vbExclamation, "Cellaméretek": Exit Sub
End If
For nArea = 1 To Selection.Areas.Count
For nRow = 0 To Selection.Areas(nArea).Rows.Count - 1
Rows(Selection.Areas(nArea).Row + nRow).RowHeight = _
Application.CentimetersToPoints(nHeight / 10)
Next nRow
Next nArea
End Sub
Sub cmdWidth_Click()
nWidth = InputBox("Add meg a szélességet mm-ben", "Szélesség", vbYesNo)
If nWidth <= 0 Then
MsgBox "A szélességnek nagyobbnak kell lennie nullánál!", vbExclamation, "Cellaméretek": Exit Sub
End If
nPoints = Application.CentimetersToPoints(nWidth / 10)
If nWidth > 473.6 Then
MsgBox "A maximális szélesség: 473,6 mm", vbExclamation, "Cellaméretek": Exit Sub
End If
Application.ScreenUpdating = False
For nArea = 1 To Selection.Areas.Count
For nCol = 0 To Selection.Areas(nArea).Columns.Count - 1
nColNo = Selection.Areas(nArea).Column + nCol
While Columns(nColNo + 1).Left - Columns(nColNo).Left - 0.1 > nPoints
Columns(nColNo).ColumnWidth = Columns(nColNo).ColumnWidth - 0.1
Wend
While Columns(nColNo + 1).Left - Columns(nColNo).Left + 0.1 < nPoints
Columns(nColNo).ColumnWidth = Columns(nColNo).ColumnWidth + 0.1
Wend
Next nCol
Next nArea
Application.ScreenUpdating = True
End Sub