컴퓨터/엑셀
vba A열 값을 기준으로 별도 파일 만들기
풍경소리^^
2025. 1. 15. 16:15
1. 초기 설정
vba
Option Explicit
Sub 개별파일만들기()
Dim rSrc As Range, r As Long
Dim sht As Worksheet
Dim i As Integer
Dim j As Integer
여기서는 변수를 선언합니다. Option Explicit는 모든 변수가 명시적으로 선언되도록 하여 오타로 인한 오류를 방지합니다.
2. 메인 시트 및 타이머
vba
Dim mainSht As Worksheet
Set mainSht = ActiveSheet ' 또는 직접 시트 이름을 지정할 수 있습니다.
Dim StartTime As Single: StartTime = VBA.Timer
Application.ScreenUpdating = False
이 부분에서는 활성 시트를 메인 시트로 설정하고, 실행 시간을 측정하기 위해 타이머를 시작합니다. 화면 업데이트를 비활성화하여 성능을 향상시킵니다.
3. 원본 범위 및 헤더
vba
Set rSrc = Range("A1").CurrentRegion
Dim vHead As Variant: vHead = rSrc.Rows(1).Value2
매크로는 데이터 범위를 식별하고 헤더 행을 배열 vHead에 저장합니다.
4. 딕셔너리 및 컬렉션 설정
vba
Dim oDic As Scripting.Dictionary: Set oDic = New Scripting.Dictionary
Dim oKeys As Object: Set oKeys = CreateObject("System.Collections.ArrayList")
Dim vKey As String
여기서는 데이터를 고유 키별로 저장하기 위한 딕셔너리 oDic와 키를 저장하기 위한 배열 리스트 oKeys를 설정합니다.
5. 데이터 루프
vba
Dim vData As Variant: vData = rSrc.Value2
For r = 2 To UBound(vData, 1)
vKey = vData(r, 1) ' 기준열 설정
If Not oDic.Exists(vKey) Then
Set oDic(vKey) = New Collection
oKeys.Add vKey
End If
oDic(vKey).Add r
Next r
매크로는 각 행을 순회하면서 첫 번째 열의 값을 키로 사용합니다. 키가 존재하지 않으면 딕셔너리와 배열 리스트에 추가하고 해당 행 번호를 저장합니다.
6. 키 정렬
vba
Dim vSht As Variant: vSht = oKeys.ToArray
키를 배열로 변환하여 정렬하고 반복하기 쉽게 만듭니다.
7. 각 키에 대한 파일 생성
vba
Dim newFile As Workbook, rowIndex As Long
Dim v As Variant
For Each v In vSht
Set newFile = Workbooks.Add
Set sht = newFile.Sheets(1)
sht.Name = v
고유 키마다 새로운 워크북을 만들고 첫 번째 시트의 이름을 키로 설정합니다.
8. 헤더 및 데이터 추가
vba
For i = 1 To UBound(vHead, 2)
sht.Cells(1, i).Value = vHead(1, i)
If mainSht.Cells(1, i).Interior.ColorIndex <> xlNone Then
sht.Cells(1, i).Interior.Color = mainSht.Cells(1, i).Interior.Color ' 헤더 배경색 복사
End If
Next i
헤더를 메인 시트에서 새로운 시트로 복사하고 배경색도 복사합니다.
vba
Dim mainRow As Long
For r = 1 To oDic(v).Count
mainRow = oDic(v)(r)
For j = 1 To UBound(vData, 2)
sht.Cells(r + 1, j).Value = vData(mainRow, j)
If mainSht.Cells(mainRow, j).Interior.ColorIndex <> xlNone Then
sht.Cells(r + 1, j).Interior.Color = mainSht.Cells(mainRow, j).Interior.Color ' 배경색 복사
End If
If j = 2 Then ' B열 (거래일) 을 날짜 형식으로 설정
sht.Cells(r + 1, j).NumberFormat = "yyyy-mm-dd"
End If
If j >= 4 And j <= 6 Then ' D, E, F 열에 숫자 형식 적용
sht.Cells(r + 1, j).NumberFormat = "#,##0"
End If
Next j
Next r
각 고유 키에 대한 데이터를 새로운 시트로 복사하고, 배경색 및 특정 열에 대한 숫자 형식을 설정합니다.
9. 시트 설정
vba
With sht.Rows("1:1")
.AutoFilter
.EntireColumn.AutoFit
End With
sht.Rows("2:2").Select
ActiveWindow.FreezePanes = True
sht.Range("A1").Select새 시트에 대해 자동 필터를 활성화하고, 열 너비를 자동으로 조정합니다. 또한, 창 분할 기능을 설정합니다.
10. 파일 저장
vba
Dim fileName As String
fileName = ThisWorkbook.Path & "\★임대료-" & v & Format(Date, "yyyymmdd") & ".xls"
Application.DisplayAlerts = False
newFile.SaveAs fileName, xlExcel8
newFile.Close SaveChanges:=False
Application.DisplayAlerts = True
Next v
새로운 워크북을 특정 파일 이름 형식으로 저장하고 닫습니다.
11. 메인 시트 복원
vba
mainSht.Activate
Application.ScreenUpdating = True
메인 시트를 다시 활성화하고 화면 업데이트를 활성화합니다.
12. 실행 시간 보고
vba
MsgBox "실행시간 " & Round(VBA.Timer - StartTime, 2) & " 초"
End Sub
"장부"시트
| 소속 | 거래일 | 구분 | 입금예정액 | 입금액 | 잔액 | 입금자 | 행번호 | 시트명 | 조합 | 미처리 |
Option Explicit
Sub 개별파일만들기()
Dim rSrc As Range, r As Long
Dim sht As Worksheet
Dim i As Integer
Dim j As Integer
' Source worksheet -> Main sheet
Dim mainSht As Worksheet
Set mainSht = ActiveSheet ' or specify the sheet name directly
' Start and GUI control
Dim StartTime As Single: StartTime = VBA.Timer
Application.ScreenUpdating = False
' Source range and header array
Set rSrc = Range("A1").CurrentRegion
Dim vHead As Variant: vHead = rSrc.Rows(1).Value2
' Dictionaries and Collections
Dim oDic As Scripting.Dictionary: Set oDic = New Scripting.Dictionary
Dim oKeys As Object: Set oKeys = CreateObject("System.Collections.ArrayList")
Dim vKey As String
' Loop through each row of data
Dim vData As Variant: vData = rSrc.Value2
For r = 2 To UBound(vData, 1)
vKey = vData(r, 1) ' 기준열 설정
If Not oDic.Exists(vKey) Then
Set oDic(vKey) = New Collection
oKeys.Add vKey
End If
oDic(vKey).Add r
Next r
' Sort keys
Dim vSht As Variant: vSht = oKeys.ToArray
' Create files for each key
Dim newFile As Workbook, rowIndex As Long
Dim v As Variant
'==========================================================================
For Each v In vSht
Set newFile = Workbooks.Add
Set sht = newFile.Sheets(1)
sht.Name = v
' Add header
For i = 1 To UBound(vHead, 2)
sht.Cells(1, i).Value = vHead(1, i)
If mainSht.Cells(1, i).Interior.ColorIndex <> xlNone Then
sht.Cells(1, i).Interior.Color = mainSht.Cells(1, i).Interior.Color ' 헤더 배경색 복사
End If
Next i
' Add data to new sheet
Dim mainRow As Long
For r = 1 To oDic(v).Count
mainRow = oDic(v)(r)
For j = 1 To UBound(vData, 2)
sht.Cells(r + 1, j).Value = vData(mainRow, j)
If mainSht.Cells(mainRow, j).Interior.ColorIndex <> xlNone Then
sht.Cells(r + 1, j).Interior.Color = mainSht.Cells(mainRow, j).Interior.Color ' 배경색 복사
End If
If j = 2 Then ' B열 (거래일) 을 날짜 형식으로 설정
sht.Cells(r + 1, j).NumberFormat = "yyyy-mm-dd"
End If
If j >= 4 And j <= 6 Then ' D, E, F 열에 숫자 형식 적용
sht.Cells(r + 1, j).NumberFormat = "#,##0"
End If
Next j
Next r
' Sheet settings
With sht.Rows("1:1")
.AutoFilter
.EntireColumn.AutoFit
End With
sht.Rows("2:2").Select
ActiveWindow.FreezePanes = True
sht.Range("A1").Select
' Save file
Dim fileName As String
fileName = ThisWorkbook.Path & "\★임대료-" & v & Format(Date, "yyyymmdd") & ".xls"
Application.DisplayAlerts = False
newFile.SaveAs fileName, xlExcel8
newFile.Close SaveChanges:=False
Application.DisplayAlerts = True
Next v
'==========================================================================
' Restore main sheet
mainSht.Activate
Application.ScreenUpdating = True
' Report completion time
MsgBox "실행시간 " & Round(VBA.Timer - StartTime, 2) & " 초"
End Sub