엑셀디자인 vba129
https://youtu.be/_mp7cqDRHs8?si=LmsF8alcJwqaH5n-
엑셀디자인vba130
https://www.youtube.com/watch?v=jpoZW0wSCK4
Sub 시트분리VBA129()
'참고 시트합치기VBA88
'계정과목별 고유목록 추출: 중복된항목제거vba47,new collection, dictionary
'기존 계정과목별 시트 삭제
'계정과목별 고유목록을 통해 시트 생성: for each next>worksheets.add
'생성된 시트에 데이터 뿌리기
'반복문+if조건문,고급필터vba35,union,배열
Dim rngJ As Range, rngJJ As Range, c As Range, rng As Range
Dim sh As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("총계정원장").Activate
With Sheets("총계정원장")
'-----계정과목별 고유목록 추출: 중복된항목제거vba47 'new collection으로 수정해봐라VBA49VBA52
.Range("J1", Cells(Rows.Count, "J").End(xlUp)).ClearContents
.Range("D1", Cells(Rows.Count, "D").End(xlUp)).Copy .Range("J1")
Set rngJ = .Columns("J").SpecialCells(2)
rngJ.RemoveDuplicates 1, xlYes '몇 개의 열, 제목 유무
'전에 있던 지역별 시트 삭제 '배열로 삭제
Set rng = .Range("J2", Cells(Rows.Count, "J").End(xlUp))
For Each sh In ThisWorkbook.Worksheets
For Each c In rng
If sh.Name = c.Value Then
sh.Delete
Exit For
End If
Next
Next
'-----지역별 고유목록을 통해 시트 생성: for each next>worksheets.add
Set rngJJ = .Range("J2", Cells(Rows.Count, "J").End(xlUp))
'For Each 개체변수 In 전체범위
For Each c In rngJJ
Worksheets.Add(after:=Sheets(Sheets.Count)).Name = c.Value '시트맨뒤에
'고급필터
.Range("K1:K2") = Application.Transpose(Array("계정과목", c)) '조건 입력
.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, .Range("K1:K2"), Sheets(c.Value).Range("A1")
Next
.Columns("J:K").Cells.Clear
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set rng = Nothing
Set rngJ = Nothing
Set rngJJ = Nothing
Set c = Nothing
Set sh = Nothing
End Sub
Sub 시트분리VBA130()
'참고 시트합치기VBA88
'계정과목별 고유목록 추출: 중복된항목제거vba47,new collection, dictionary
'기존 계정과목별 시트 삭제
'계정과목별 고유목록을 통해 시트 생성: for each next>worksheets.add
'생성된 시트에 데이터 뿌리기
'반복문+if조건문,고급필터vba35,union,배열
Dim rngD As Range, c As Range
Dim sh As Worksheet
Dim nc As New Collection
Dim e
Dim arr()
Dim i As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("총계정원장").Activate
With Sheets("총계정원장")
'-----계정과목별 고유목록 추출: 중복된항목제거vba47 'new collection으로 수정해봐라VBA49VBA52
' .Range("J1", Cells(Rows.Count, "J").End(xlUp)).ClearContents
'new collection개체이용 고유목록 추출
Set rngD = .Range("D2", .Cells(Rows.Count, "D").End(xlUp))
On Error Resume Next
For Each c In rngD
If Len(c) Then
nc.Add Trim(c), CStr(Trim(c)) '이유 설명
End If
Next
On Error GoTo 0
'전에 있던 지역별 시트 삭제 '배열로 삭제 '배열로 변경
For Each sh In ThisWorkbook.Worksheets
For Each e In nc
If sh.Name = e Then
ReDim Preserve arr(i)
arr(i) = e
i = i + 1
Exit For
End If
Next
Next
If Not Not arr Then 'arr변수에 값이 있으면
Sheets(arr).Delete
End If
'-----지역별 고유목록을 통해 시트 생성: for each next>worksheets.add
'For Each 개체변수 In 전체범위
For Each e In nc
Worksheets.Add(after:=Sheets(Sheets.Count)).Name = e '시트맨뒤에
'고급필터
.Range("K1:K2") = Application.Transpose(Array("계정과목", e)) '조건 입력
.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, .Range("K1:K2"), Sheets(e).Range("A1")
Next
.Columns("J:K").Cells.Clear
.Activate
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Erase arr
Set rngD = Nothing
Set c = Nothing
Set sh = Nothing
Set nc = Nothing
End Sub
계정별원장-vba130-nc-final.xls
0.17MB
Sub 시트분리VBA130()
'참고 시트합치기VBA88
'계정과목별 고유목록 추출: 중복된항목제거vba47,new collection, dictionary
'기존 계정과목별 시트 삭제
'계정과목별 고유목록을 통해 시트 생성: for each next>worksheets.add
'생성된 시트에 데이터 뿌리기
'반복문+if조건문,고급필터vba35,union,배열
Dim rngD As Range, c As Range
Dim sh As Worksheet
Dim nc As New Collection
Dim e
Dim arr()
Dim i As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("총계정원장").Activate
With Sheets("총계정원장")
'-----계정과목별 고유목록 추출: 중복된항목제거vba47 'new collection으로 수정해봐라VBA49VBA52
' .Range("J1", Cells(Rows.Count, "J").End(xlUp)).ClearContents
'new collection개체이용 고유목록 추출
Set rngD = .Range("D2", .Cells(Rows.Count, "D").End(xlUp))
On Error Resume Next
For Each c In rngD
If Len(c) Then
nc.Add Trim(c), CStr(Trim(c)) '이유 설명
End If
Next
On Error GoTo 0
'전에 있던 지역별 시트 삭제 '배열로 삭제 '배열로 변경
For Each sh In ThisWorkbook.Worksheets
For Each e In nc
If sh.Name = e Then
ReDim Preserve arr(i)
arr(i) = e
i = i + 1
Exit For
End If
Next
Next
If Not Not arr Then 'arr변수에 값이 있으면
Sheets(arr).Delete
End If
'-----지역별 고유목록을 통해 시트 생성: for each next>worksheets.add
'For Each 개체변수 In 전체범위
For Each e In nc
Worksheets.Add(after:=Sheets(Sheets.Count)).Name = e '시트맨뒤에
'고급필터
.Range("K1:K2") = Application.Transpose(Array("계정과목", e)) '조건 입력
.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, .Range("K1:K2"), Sheets(e).Range("A1")
잔액월계합계
타이틀넣기
activeSheet.Range("I4").Value = e
activeSheet.Columns("A").Hidden = True
activeSheet.Columns("D").Hidden = True
activeSheet.Columns("B:C").ColumnWidth = 4
activeSheet.Columns("E:I").ColumnWidth = 15
With activeSheet.PageSetup
' 왼쪽 여백을 1인치로 설정
.LeftMargin = Application.CentimetersToPoints(1)
' 오른쪽 여백을 1인치로 설정
.RightMargin = Application.CentimetersToPoints(1)
End With
Next
.Columns("J:K").Cells.Clear
.Activate
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Erase arr
Set rngD = Nothing
Set c = Nothing
Set sh = Nothing
Set nc = Nothing
End Sub
Sub CreateLedger()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim account As String, description As String
Dim debit As Double, credit As Double, balance As Double
' 원장을 작성할 시트 선택 (Sheet1에 해당하는 시트로 가정)
Set ws = activeSheet
' 데이터가 있는 마지막 행 찾기
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' 시작 잔액은 0으로 설정
balance = 0
' 제목 행 추가
ws.Cells(1, 11).Value = "잔액"
' 데이터를 반복하며 원장 작성
For i = 2 To lastRow
account = ws.Cells(i, 4).Value
description = ws.Cells(i, 5).Value
debit = ws.Cells(i, 7).Value
credit = ws.Cells(i, 8).Value
' 차변 및 대변에 따라 잔액 조정
balance = balance + debit - credit
' 원장에 데이터 입력
ws.Cells(i, 9).Value = balance
Next i
End Sub
Sub InsertSubtotalAndTotal5()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim debit As Double, credit As Double, balance As Double
Dim currMonth As Integer, prevMonth As Integer
Dim subtotalRow As Long, totalRow As Long
Dim insertedRows As Long
Set ws = activeSheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
insertedRows = 0
balance = 0
prevMonth = ws.Cells(2, 2).Value
For i = 2 To lastRow + 1
currMonth = ws.Cells(i + insertedRows, 2).Value
' Debug.Print "=>", currMonth
If currMonth <> 0 Then
If IsNumeric(ws.Cells(i + insertedRows, 7).Value) Then
debit = ws.Cells(i + insertedRows, 7).Value
Else
debit = 0
End If
If IsNumeric(ws.Cells(i + insertedRows, 8).Value) Then
credit = ws.Cells(i + insertedRows, 8).Value
Else
credit = 0
End If
balance = balance + debit - credit
ws.Cells(i + insertedRows, 9).Value = balance
End If
If currMonth <> prevMonth Then
' 월계 행 삽입
subtotalRow = i + insertedRows
ws.Rows(subtotalRow).Insert
ws.Cells(subtotalRow, 4).Value = "월계"
ws.Cells(subtotalRow, 7).Formula = "=SUMIFS(G$2:G" & i + insertedRows & ", B$2:B" & i + insertedRows & ", " & prevMonth & ")"
ws.Cells(subtotalRow, 8).Formula = "=SUMIFS(H$2:H" & i + insertedRows & ", B$2:B" & i + insertedRows & ", " & prevMonth & ")"
' 합계 행 삽입
totalRow = subtotalRow + 1
ws.Rows(totalRow).Insert
ws.Cells(totalRow, 4).Value = "합계"
ws.Cells(totalRow, 7).Formula = "=SUMIFS(G$2:G" & lastRow + insertedRows + 1 & ", D$2:D" & lastRow + insertedRows + 1 & ", ""월계"")"
ws.Cells(totalRow, 8).Formula = "=SUMIFS(H$2:H" & lastRow + insertedRows + 1 & ", D$2:D" & lastRow + insertedRows + 1 & ", ""월계"")"
insertedRows = insertedRows + 2
prevMonth = currMonth
End If
Next i
End Sub
Sub 잔액월계합계()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim debit As Double, credit As Double, balance As Double
Dim currMonth As Integer, prevMonth As Integer
Dim subtotalRow As Long, totalRow As Long
Dim insertedRows As Long
' 현재 활성화된 시트를 가져옵니다.
Set ws = activeSheet
' 데이터가 있는 마지막 행을 찾습니다.
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
insertedRows = 0
balance = 0
prevMonth = ws.Cells(2, 2).Value
' 데이터를 반복하여 처리합니다.
For i = 2 To lastRow + 1
' 현재 월을 가져옵니다.
currMonth = ws.Cells(i + insertedRows, 2).Value
' 현재 월이 0이 아닌 경우에만 처리합니다.
If currMonth <> 0 Then
' 차변 및 대변 값을 가져옵니다.
debit = IIf(IsNumeric(ws.Cells(i + insertedRows, 7).Value), ws.Cells(i + insertedRows, 7).Value, 0)
credit = IIf(IsNumeric(ws.Cells(i + insertedRows, 8).Value), ws.Cells(i + insertedRows, 8).Value, 0)
' 잔액을 업데이트합니다.
balance = balance + debit - credit
ws.Cells(i + insertedRows, 9).Value = balance
End If
' 이전 월과 현재 월이 다른 경우에만 처리합니다.
If currMonth <> prevMonth Then
' 월계 행을 삽입합니다.
subtotalRow = i + insertedRows
ws.Rows(subtotalRow).Insert
ws.Cells(subtotalRow, 2).Value = "[월 계]"
With ws.Range(Cells(subtotalRow, 1), Cells(subtotalRow, 6))
' 수평 정렬을 가운데 정렬로 설정합니다.
.Columns.HorizontalAlignment = xlCenterAcrossSelection
' 수직 정렬을 가운데 정렬로 설정합니다.
.VerticalAlignment = xlCenter
End With
' 선택된 범위의 상단에 실선을 추가합니다.
With ws.Range(Cells(subtotalRow, 1), Cells(subtotalRow, 9)).Borders(xlEdgeTop)
.LineStyle = xlContinuous ' 선 스타일을 실선으로 설정합니다.
.ColorIndex = xlAutomatic ' 선의 색상을 자동으로 설정합니다.
.TintAndShade = 0 ' 색상의 음영을 설정합니다.
.Weight = xlThin ' 선의 두께를 얇게 설정합니다.
End With
ws.Cells(subtotalRow, 7).Formula = "=SUMIFS(G$2:G" & i + insertedRows & ", B$2:B" & i + insertedRows & ", " & prevMonth & ")"
ws.Cells(subtotalRow, 8).Formula = "=SUMIFS(H$2:H" & i + insertedRows & ", B$2:B" & i + insertedRows & ", " & prevMonth & ")"
' 합계 행을 삽입합니다.
totalRow = subtotalRow + 1
ws.Rows(totalRow).Insert
ws.Cells(totalRow, 2).Value = "[합 계]"
With ws.Range(Cells(subtotalRow, 1), Cells(subtotalRow, 6))
' 수평 정렬을 가운데 정렬로 설정합니다.
.Columns.HorizontalAlignment = xlCenterAcrossSelection
' 수직 정렬을 가운데 정렬로 설정합니다.
.VerticalAlignment = xlCenter
End With
With ws.Range(Cells(totalRow, 1), Cells(totalRow, 9)).Borders(xlEdgeBottom)
.LineStyle = xlContinuous ' 선 스타일을 실선으로 설정합니다.
.ColorIndex = xlAutomatic ' 선의 색상을 자동으로 설정합니다.
.TintAndShade = 0 ' 색상의 음영을 설정합니다.
.Weight = xlThin ' 선의 두께를 얇게 설정합니다.
End With
ws.Cells(totalRow, 7).Formula = "=SUMIFS($G$2:$G" & lastRow + insertedRows + 1 & ", $B$2:$B" & lastRow + insertedRows + 1 & ", ""[월 계]"")"
ws.Cells(totalRow, 8).Formula = "=SUMIFS($H$2:$H" & lastRow + insertedRows + 1 & ", $B$2:$B" & lastRow + insertedRows + 1 & ", ""[월 계]"")"
' 삽입된 행 수를 업데이트합니다.
insertedRows = insertedRows + 2
' 이전 월을 현재 월로 업데이트합니다.
prevMonth = currMonth
End If
Next i
End Sub
Sub 타이틀넣기()
Dim templateSheet As Worksheet
' Dim activeSheet As Worksheet
Dim copyRange As Range
Dim insertRange As Range
' "양식" 시트와 활성화된 시트를 설정합니다.
Set templateSheet = ThisWorkbook.Sheets("양식")
' Set activeSheet = activeSheet
' 복사할 범위를 설정합니다.
Set copyRange = templateSheet.Range("A1:I4")
' 삽입할 범위를 설정합니다.
' Set insertRange = activeSheet.Range("A1")
' 복사한 내용을 상단에 추가합니다.
copyRange.Copy
' insertRange.Insert Shift:=xlDown
activeSheet.Range("A1").Insert Shift:=xlDown
Application.CutCopyMode = False ' 복사 모드를 해제합니다.
' 또는 아래와 같이 복사 후 붙여넣기를 사용할 수도 있습니다.
' copyRange.Copy Destination:=insertRange
End Sub'컴퓨터 > 엑셀' 카테고리의 다른 글
| 엑셀vba 시트 지우기 (0) | 2024.03.01 |
|---|---|
| 엑셀vba 항목별 각 시트로 나누기-계정별원장-ADODB.Recordset-excelandvba (0) | 2024.02.29 |
| ms word vba (0) | 2024.02.23 |
| 엑셀에 종이양식 넣어 쉽게 편집하기 (0) | 2024.01.31 |
| vba 내선번호 textbox listbox drag and drop 셀색 (0) | 2023.12.06 |