카카오떡 VBA 코드를 만들었는데 거기에 추가적으로 실행문을 하나 더 입력해서 동시에 실행시킬수 있는지 궁금합니다.
아래식은 B1과 같은 패턴을 오른쪽에서 1개만 찾고 각각 왼쪽에 있는 값과 비교해서 맞으면 O 틀리면 X로 도출해 내는 코드이고 이걸 B1C1 BC1D1 이런식으로 1개씩 패턴을 늘려가서 결과값을 찾되 더이상 찾는 비교군이 나오지 안을때는 빈칸으로 만드는 매크로 식입니다.
여기에 추가로 A1과 같은 패턴을 찾고 A1과 같은 패턴의 오른쪽 값이 어떤 값인지를 추출해내되 패턴을 1개에서 2개 3개 이런식을 늘려가고 싶습니다.
그러면 처음에 A1과 똑같은 패턴을 찾으면 B1이되고 그 오른쪽 값은 0이 되겠죠 다음은 A1B1과 같은 패턴을 찾으면 D1E1이 되고 오른쪽 값은 1이 되겠죠 이런 식이구요 아랫 사진에 A, AB,ABC, ABCD는 이해를 돕기 위해서 써놓았는데 구지 출력되지 안아도 상관없는데 다만 결과값이 안나오면 그 때부턴 빈칸이 되도록 하는 VBA 코드식을 만들고 싶은데 어떻게 하면 될까요 그리고 그 코드식을 기존 코드식에 하나더 추가하면 버튼을 눌렀을때 실행이 될까요? 고수님들 도와주세요..ㅠㅠ
VBA 코드식
Option Explicit
Public Sub PatOX()
On Error GoTo EH
Dim ws As Worksheet: Set ws = ActiveSheet
Dim stp As Long: stp = 0
Dim eRow As Long: eRow = 2 '// 데이터 행
Dim bCol As Long: bCol = 2 '// B열부터 패턴
Dim oCol As Long: oCol = 1 '// 출력 시작열(A)
Dim rRow As Long: rRow = 5 '// 결과 출력 행(5행만)
stp = 10
Dim lc As Long
lc = ws.Cells(eRow, ws.Columns.Count).End(xlToLeft).Column
If lc <= bCol Then Exit Sub
stp = 20
Dim arr As Variant
arr = ws.Range(ws.Cells(eRow, 1), ws.Cells(eRow, lc)).Value2
stp = 30
Dim eCol As Long
eCol = UBound(arr, 2) '// 실제 읽힌 마지막 열
If eCol <= bCol Then Exit Sub
Dim n As Long: n = eCol - bCol + 1
If n < 2 Then Exit Sub
stp = 40
Dim sB() As Byte
ReDim sB(1 To n)
Dim i As Long, v As Variant
For i = 1 To n
v = arr(1, bCol + i - 1)
If v = 1 Or v = "1" Then
sB(i) = 49 '// "1"
Else
sB(i) = 48 '// "0"
End If
Next i
stp = 50
Dim Z() As Long
Z = ZCal(sB, n)
stp = 60
Dim ans() As Long
ans = AnsZ(Z, n)
stp = 70
Dim m As Long
m = 100
If m > n Then m = n
stp = 80
'★ 결과만 담는 1행짜리 배열(라벨 행 없음)
Dim out As Variant
ReDim out(1 To 1, 1 To m)
Dim aL As Variant: aL = arr(1, bCol - 1) '// A1
Dim fPos As Long, fCol As Long
For i = 1 To m
fPos = ans(i)
'재등장 못찾음 => 빈칸
If fPos = 0 Then
out(1, i) = ""
Else
fCol = bCol + fPos - 1
'비교 셀(왼쪽)이 범위 밖이면 => 빈칸(원하신 "비교군 없으면 빈칸" 기준)
If fCol - 1 < 1 Or fCol - 1 > eCol Then
out(1, i) = ""
Else
If CStr(aL) = CStr(arr(1, fCol - 1)) Then
out(1, i) = "O"
Else
out(1, i) = "X"
End If
End If
End If
Next i
stp = 90
'★ 5행에만 출력 (4행은 전혀 사용/수정하지 않음)
ws.Range(ws.Cells(rRow, oCol), ws.Cells(rRow, oCol + m - 1)).Value = out
Exit Sub
EH:
MsgBox "오류 " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
"stp=" & stp, vbCritical
End Sub
'// Z-Algorithm (경계 체크 강화)
Private Function ZCal(ByRef sB() As Byte, ByVal n As Long) As Long()
Dim Z() As Long
ReDim Z(1 To n)
Dim L As Long, R As Long, i As Long, k As Long
L = 1: R = 1
Z(1) = 0
For i = 2 To n
If i <= R Then
k = i - L + 1
If k < 1 Or k > n Then Err.Raise 9, , "ZCal: k out (" & k & ")"
Z(i) = R - i + 1
If Z(k) < Z(i) Then Z(i) = Z(k)
Else
Z(i) = 0
End If
Do While (i + Z(i) <= n)
If (1 + Z(i) < 1) Or (1 + Z(i) > n) Or (i + Z(i) < 1) Or (i + Z(i) > n) Then
Err.Raise 9, , "ZCal: idx out"
End If
If sB(1 + Z(i)) <> sB(i + Z(i)) Then Exit Do
Z(i) = Z(i) + 1
Loop
If i + Z(i) - 1 > R Then
L = i
R = i + Z(i) - 1
End If
Next i
ZCal = Z
End Function
'// ans(L)=접두 길이 L이 다시 나타나는 최소 시작 위치
Private Function AnsZ(ByRef Z() As Long, ByVal n As Long) As Long()
Dim hd() As Long, nx() As Long
ReDim hd(0 To n)
ReDim nx(0 To n)
Dim i As Long, zL As Long
For i = 2 To n
zL = Z(i)
If zL > 0 Then
If zL < 0 Or zL > n Then Err.Raise 9, , "AnsZ: zL out"
nx(i) = hd(zL)
hd(zL) = i
End If
Next i
Dim ans() As Long
ReDim ans(1 To n)
Dim minP As Long: minP = 0
Dim L As Long, p As Long
For L = n To 1 Step -1
p = hd(L)
Do While p <> 0
If p < 0 Or p > n Then Err.Raise 9, , "AnsZ: p out"
If minP = 0 Or p < minP Then minP = p
p = nx(p)
Loop
ans(L) = minP
Next L
AnsZ = ans
End Function
