조합 패턴 테이블을 만드는 Excel 매크로
이게 뭐야?
여러 요소의 모든 조합, 잘 자주하는 사람입니다.
요소를 늘어놓고, 버튼 하나로 좋은 느낌으로 표로 하고 싶었다.
이미지
코드
Option Explicit
Sub 組み合わせ表()
Dim t As Range, d As Range, e As Range, r As Range
With ActiveCell.CurrentRegion
Set t = .Resize(1)
Set d = t.Offset(, t.Count + 1)
t.Copy d
For Each e In t
Set r = PatternMatrix(r, e.Offset(1).Resize(e.End(xlDown).Row - e.Row), d.Offset(1))
Next
End With
SmartBorder d.CurrentRegion
End Sub
Private Function PatternMatrix(baseRange As Range, addRange As Range, distRange As Range) As Range
Dim arx, acx, aar
aar = ToArray(addRange)
arx = UBound(aar)
acx = 1
Dim brx, bcx, bar
If baseRange Is Nothing Then
brx = 1
Else
bar = ToArray(baseRange)
brx = UBound(bar, 1)
bcx = UBound(bar, 2)
End If
Dim rx, cx, arr
rx = brx * arx
cx = bcx + acx
Set PatternMatrix = distRange.Resize(rx, cx)
arr = ToArray(PatternMatrix)
Dim br, bc, ar, ac, r, c
For br = 1 To brx: For ar = 1 To arx
r = r + 1
For c = 1 To bcx
arr(r, c) = IIf(ar = 1, bar(br, c), vbNullString)
Next c
arr(r, bcx + 1) = aar(ar, 1)
Next ar, br
PatternMatrix.Value = arr
End Function
Private Function SmartBorder(Optional rng As Range) As Range
Set SmartBorder = IIf(rng Is Nothing, ActiveWindow.RangeSelection, rng)
With SmartBorder
.Borders.LineStyle = xlNone
.BorderAround xlContinuous
For Each rng In .Cells
If Not IsEmpty(rng) Then rng.Resize(.Cells(.Count).Row - rng.Row + 1, .Cells(.Count).Column - rng.Column + 1).BorderAround xlContinuous
Next
End With
End Function
Private Function ToArray(rng As Range) As Variant
ToArray = rng.Value
If Not IsArray(ToArray) Then
Dim wArr(1 To 1, 1 To 1)
wArr(1, 1) = ToArray
ToArray = wArr
End If
End Function
추가 (2020.1.26)
잘 움직이지 않으므로 수정했습니다.
Reference
이 문제에 관하여(조합 패턴 테이블을 만드는 Excel 매크로), 우리는 이곳에서 더 많은 자료를 발견하고 링크를 클릭하여 보았다 https://qiita.com/jinoji/items/447416e302a13824d400텍스트를 자유롭게 공유하거나 복사할 수 있습니다.하지만 이 문서의 URL은 참조 URL로 남겨 두십시오.
우수한 개발자 콘텐츠 발견에 전념 (Collection and Share based on the CC Protocol.)