【討論】用 VBA 畫一個菱形排列

**leonchou** · 2003-10-10, 06:18 PM

這好像是古早 Basic 的題目..

||
Sub aa()
[A1:A5].ClearContents
For i = 1 To 5
v_star = ""
If i > 3 Then c = c - 1 Else c = c + 1
For j = 1 To c
v_star = v_star & "* "
Next j
v_star = Space(c + 3 - c * 2) & v_star
Cells(i, 1) = v_star
Next i
End Sub

效果如下 (因這裡會消掉前置空格,只好以底線代替)
__*
_* *
* * *
_* *
__*

有誰可以提供更簡潔或更理想的寫法嗎?
還有，這裡最大數 3，能否改成可任意指定的?
討論一下嘛。

**VicLin** · 2003-10-10, 06:53 PM

[A1:A5].ClearContents
這行是啥
沒看過這種寫法

**jute** · 2003-10-10, 09:07 PM

呃...更理想的寫法我想不出來（功力未到家）

不過任意指定最大值的我已改成了，這樣如何：

語法:

Sub aa()
    mx = InputBox("輸入最大值：")
    If mx = "" Or Not IsNumeric(mx) Then Exit Sub
    [A1].EntireColumn.ClearContents
    For i = 1 To mx * 2 - 1
        v_star = ""
        c = IIf(i > Val(mx), c - 1, c + 1)
        For j = 1 To c
            v_star = v_star & "* "
        Next j
        v_star = Space(c + mx - c * 2) & v_star
        Cells(i, 1) = v_star
    Next i
End Sub

請指教

**leonchou** · 2003-10-10, 09:43 PM

最初由 VicLin 發表
[A1:A5].ClearContents
這行是啥
沒看過這種寫法

是一種簡寫，
等於 Range("A1:A5").ClearContents 。

Range("A1") 可以寫成 [A1] ；
定義名稱"ABC"，Range("ABC") 可以寫成 [ABC] ，
以此類推。

**ivantw** · 2003-10-10, 10:10 PM

可修改tCnt大小來變更菱形大小。

語法:

Sub DrawArr()
    Dim tCnt As Long
    Dim tIdx As Long
    
    tCnt = 20
    
    [A1:A65535].ClearContents
    For tIdx = 1 To tCnt
        Cells(tIdx, 1) = String(tCnt - tIdx, " ") & String(tIdx, "*")
        Cells(tCnt + tIdx - 1, 1) = String(tIdx - 1, " ") & String(tCnt - tIdx + 1, "*")
    Next tIdx
End Sub

**leonchou** · 2003-10-10, 11:37 PM

jute弟，謝謝你讓我想起還有 IIF 這東東

Ivan弟，這只用一個loop的手法真是高招，愚兄暫時還不能參透~ ^^||

但題目是要求每兩個star中間有一個空白，
我承認沒有說的很清楚..
但因此String函數就派不上用場了是吧?

anyway，先把這犀利的程式稍改一下，你看如何：

語法:

Sub aaa1()
[A:A].ClearContents
x = Application.InputBox("Enter Number ", Type:=1)
For i = 1 To x
    Cells(i, 1) = Space(x - i) & String(i, "*")
    Cells(x + i - 1, 1) = Space(i - 1) & String(x - i + 1, "*")
Next i
End Sub

**leonchou** · 2003-10-10, 11:40 PM

另外，請原諒題目說的不夠清楚..
其實也有一部份是後來才發現 --
請把 A 欄的字型分別設為固定寬度和非固定寬度(如細明体和新細明体)，
看看結果有何不同

如果star之間沒有空白，那套用兩種字型的結果會差很多..

在別的地方得到的啟發：ABS函數真好用。^^
因此我想要的正解是像這樣

語法:

Sub aaa2()
[A:A].ClearContents
x = Application.InputBox("Enter Number ", Type:=1)
For i = 1 To x * 2 - 1
    v_star = Space(Abs(x - i))
    For j = Abs(x - i) To x - 1
        v_star = v_star & "* "
    Next
    Cells(i, 1) = v_star
Next i
[A:A].EntireColumn.AutoFit
End Sub

我覺得應該是符合題目(..算是我的本意啦)
的前提下最簡潔的答案了吧..

當然，如果不要空格，那非Ivan的答案莫屬啦~

對了，忘了補充：
Ivan你竟在10月10日10時10分貼文，佩服佩服!

**jute** · 2003-10-11, 12:58 AM

雖然是投機取巧，但若是用在 Excel 上，套用 formula 也是可以吧：

語法:

Sub DrawArr()
    Dim tCnt As Long
    Dim tIdx As Long
    tCnt = InputBox("Enter value:")
    [A:A].ClearContents
    For tIdx = 1 To tCnt
        Cells(tIdx, 1).Formula = "=rept(char(32)," & tCnt - tIdx & _
            ") & rept(char(42) & char(32)," & tIdx & ")"
        Cells(tCnt + tIdx - 1, 1).Formula = "=rept(char(32)," & tIdx - 1 & _
            ") & rept(char(42) & char(32)," & tCnt - tIdx + 1 & ")"
    Next tIdx
End Sub

不過若不是 Excel，如何只用一個 for loop 達到目的就不曉得了