컴퓨터/엑셀
vba 임대료 주소 배열에 저장 배열에 저장된 주소에 셀색 칠하기, access 외부데이터 가져오기
풍경소리^^
2024. 4. 20. 22:58
도구-참조-Microsoft ActiveX Data Objects 2.8 Library
Sub 가져오기_임대료_accdb()
' Ctrl + Shift + G
Dim db As Database
Dim rs As Recordset
On Error Resume Next
Sheets("장부").Range("a2", Sheets("장부").Range("a2").End(xlDown)).Resize(, 11).ClearContents
Set db = OpenDatabase(ThisWorkbook.Path & "\★임대료.accdb")
Set rs = db.OpenRecordset("t★장부")
With ActiveSheet.QueryTables.Add(Connection:=rs, Destination:=Range("a2"))
' .Name = "데이터"
.FieldNames = False
.AdjustColumnWidth = False
.RefreshStyle = xlInsertDeleteCells
.Refresh BackgroundQuery:=True
End With
Set rs = Nothing
db.Close
Set db = Nothing
' Columns("A:A").Select
' Selection.Delete Shift:=xlToLeft
' Call onetocolor
Range("A2").Select
End Sub
Sub 대리점입금관리_행값매기기1_Modify()
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Dim Dic As Object
Dim a, k
Dim i As Long
Dim rng As Range
Dim rowsCnt As Integer
Dim baseCol As String
Dim targetCol As String, targetCol_2
baseCol = "A"
targetCol = "H"
targetCol_2 = "I"
' rowsCnt = Cells(Rows.Count, baseCol).End(3).Row
rowsCnt = Cells(Rows.Count, baseCol).End(xlUp).Row
Set rng = Range(Cells(2, targetCol), Cells(rowsCnt, targetCol))
Range(Cells(2, targetCol), Cells(Rows.Count, targetCol)).Resize(, 1).ClearContents
' Range(Cells(2, targetCol_2), Cells(Rows.Count, targetCol_2)).ClearContents
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To rowsCnt - 1
Dic.Add i, ActiveSheet.Name
Next i
k = Dic.keys '행번호
a = Dic.items '시트이름
Range("H2").Resize(UBound(a) + 1) = WorksheetFunction.Transpose(k)
Range("I2").Resize(UBound(a) + 1) = WorksheetFunction.Transpose(a)
End Sub
Sub colorIndex_K()
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Dim color_index As Integer
Dim Dic As Object
Dim a, k
Dim i As Long
Dim rng As Range
Dim rowsCnt As Integer
Dim baseCol As String, baseCol_2 As String
Dim targetCol As String, targetCol_2
baseCol = "D"
baseCol_2 = "E"
' targetCol = "u"
targetCol_2 = "K"
' rowsCnt = Cells(Rows.Count, baseCol_2).End(3).Row
rowsCnt = Cells(Rows.Count, "a").End(xlUp).Row
Set rng = Range(Cells(2, targetCol_2), Cells(rowsCnt, targetCol_2))
rng.ClearContents
' Range(Cells(2, targetCol_2), Cells(Rows.Count, targetCol_2)).ClearContents
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To rowsCnt - 1
' Dic.Add i, (IIf(Cells(i + 1, baseCol).Interior.ColorIndex > 0, 1, 0) + IIf(Cells(i + 1, baseCol_2).Interior.ColorIndex > 0, 1, 0))
Dic.Add i, IIf(Cells(i + 1, baseCol).Interior.ColorIndex > 0 Or Cells(i + 1, baseCol_2).Interior.ColorIndex > 0, 1, 0)
Next i
k = Dic.items
Range("K2").Resize(UBound(k) + 1) = WorksheetFunction.Transpose(k)
End Sub
Sub SortDataByDateColumn()
Dim ws As Worksheet
Dim dataRange As Range
Dim sortRange As Range
' Call onetocolor
' 작업할 시트 선택 또는 시트 이름 지정
Set ws = ThisWorkbook.Sheets("장부") ' 시트 이름을 변경하세요.
' 데이터 범위 지정 (A열부터 K열까지의 데이터를 포함하는 범위)
Set dataRange = ws.Range("A1:K" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
' 정렬 기준 열 범위 지정 (B열이라고 가정)
Set sortRange = ws.Range("B1:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
' 정렬을 위해 데이터 범위와 함께 정렬 기준 열 범위를 지정하고 오름차순으로 정렬
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=sortRange, _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange dataRange
.Header = xlYes ' 제목 행이 있음을 나타냄
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
End Sub
Sub sumif하기_Modify()
' Ctrl + Shift + E
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Dim lRow As Long
Dim lSum As Long
Dim oDic As Object
Dim rowsCnt_A As Integer, rowsCnt_F As Integer
Dim baseCol As String
Dim targetCol_A As String, targetCol_F As String
Dim rng_balance As Range, rng_K As Range, rng_B As Range
Dim vKey As Variant
Dim vSum As Double
Dim ja As Variant
Dim jk As Variant
Dim results() As Variant
Cells.FormatConditions.Delete ' 조건부서식 지우기
Call 대리점입금관리_행값매기기1_Modify
Call onetocolor
Call colorIndex_K
Call SortDataByDateColumn
targetCol_A = "A"
rowsCnt_A = Cells(Rows.Count, targetCol_A).End(3).Row
targetCol_F = "F"
rowsCnt_F = Cells(Rows.Count, targetCol_F).End(3).Row
Set rng_balance = Range(Cells(2, targetCol_F), Cells(rowsCnt_F, targetCol_F))
rng_balance.ClearContents
If rowsCnt_A <> rowsCnt_F Then
Set rng_K = Range(Cells(rowsCnt_F + 1, "A"), Cells(Rows.Count, "A").End(xlUp)).Offset(, 10)
rng_K = 1
rng_K.Offset(, -6).Interior.Color = vbYellow
End If
ReDim results(1 To Cells(Rows.Count, 1).End(xlUp).Row, 1 To 1)
Set oDic = CreateObject("Scripting.Dictionary")
For lRow = 2 To UBound(results)
vKey = Cells(lRow, 1).Value
vSum = Cells(lRow, 4).Value - Cells(lRow, 5).Value
If oDic.Exists(vKey) Then
oDic(vKey) = oDic(vKey) + vSum ' 항목합계
Else
oDic.Add vKey, vSum
End If
results(lRow - 1, 1) = oDic(vKey) ' 여기 -1
Next lRow
Range("F2").Resize(UBound(results), 1).Value = results
Range("A2", Cells(Rows.Count, "A").End(xlUp)).Offset(, 3).Resize(, 3).NumberFormatLocal = "#,##0_ "
Range("A2", Cells(Rows.Count, "A").End(xlUp)).Offset(, 1).NumberFormatLocal = "yyyy-mm-dd"
MsgBox "잔액 계산 완료"
End Sub
주소 배열에 저장
배열에 저장된 주소에 셀색 칠하기
Sub onetocolor()
Dim ws As Worksheet
Dim rngK As Range, rngDE As Range
Dim i As Long, j As Long, k As Long
Dim arr() As String
Dim lastRow As Long
Dim addr As Variant
Dim cell As Range
' 장부 시트를 설정합니다.
Set ws = Sheets("장부")
' 장부 시트의 마지막 행을 찾습니다.
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
' D와 E 열의 범위를 설정하고 셀 배경색을 지웁니다.
Set rngDE = ws.Range("D2:E" & lastRow)
rngDE.Interior.Color = xlNone
' K 열의 범위를 설정합니다.
Set rngK = ws.Range("K2:K" & lastRow)
' 배열 초기화
ReDim arr(1 To 1) As String
k = 1
' 주소를 배열에 추가합니다.
For i = 1 To rngK.Rows.Count
If rngK.Cells(i, 1).Value = 1 Then ' K열의 값이 1인 경우
For j = 1 To rngDE.Columns.Count
If rngDE.Cells(i, j) <> "" Then ' D열 또는 E열의 값이 비어 있지 않은 경우
' 배열 크기를 동적으로 조정하여 셀 주소 추가
ReDim Preserve arr(1 To k) As String
' 주소 저장
arr(k) = rngDE.Cells(i, j).Address
k = k + 1
End If
Next j
End If
Next i
' 배열에 저장된 셀 주소에 대해 한꺼번에 색상 변경
For i = LBound(arr) To UBound(arr)
ws.Range(arr(i)).Interior.Color = vbYellow ' 노란색
Next i
End Sub
access 외부데이터 가져오기 - 기존테이블 삭제
Sub ImportExcelData()
Dim accApp As Object
Dim tableName As String
Dim conn As Object
Dim cmd As Object
Dim strSQL As String
Dim filePath As String
' Connection 객체 생성
Set conn = CreateObject("ADODB.Connection")
' 연결 문자열 설정
' conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\notebook\OneDrive\문서\입출금\엑셀외부데이터가져오기.accdb"
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Access.Application.CurrentProject.Path & "\엑셀데이터가져오기.accdb"
' Command 객체 생성
Set cmd = CreateObject("ADODB.Command")
cmd.ActiveConnection = conn
' "t★장부" 테이블의 내용을 삭제하는 SQL 문 작성
strSQL = "DELETE FROM [t★장부]"
' Command 실행
cmd.CommandText = strSQL
cmd.Execute
' 리소스 정리
conn.Close
Set conn = Nothing
Set cmd = Nothing
' Access Application 생성
Set accApp = CreateObject("Access.Application")
' accApp.Visible = True ' Access 창을 보이게 함
' Excel 파일에서 "장부" 시트의 데이터를 가져와서 Access 테이블에 추가
filePath = Access.Application.CurrentProject.Path & "\" & "★임대료-사장님어머님.xls"
If Dir(filePath) <> "" Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "t★장부", filePath, True
Else
MsgBox "파일을 찾을 수 없습니다: " & filePath
End If
' 리소스 해제
accApp.Quit
Set accApp = Nothing
End Sub