10월 8 2015
엑셀(EXCEL) – 각 행별로 셀 패턴별 숫자 합치기
데이터를 다룰 때 정형화되면 좋은데 아래의 질문처럼 정형화된 것도 안된 것도 아닌 질문이
올라오면 참 어떤 형식을 찾는데 힘이 듦니다. 질문에는 정형화된 것처럼 나오는데 만약에
각 열마다 크기가 달라지면 문제가 생깁니다. 물론 배열수식에서 범위를 최대한 넓혀 잡으면
되지만 VBA의 관점에서 보면 난감한 내용입니다.
http://www.clien.net/cs2/bbs/board.php?bo_table=kin&wr_id=3548380
(엑셀 매크로 질문 드립니다, 행별 특정 값 옆의 값 취합)
첨부의 그림과 같이 “X” 마크 옆의 값들을 취합하라는 내용입니다. 루틴은 간단합니다.
Option Explicit
Sub Sum_By_Mark()
Dim RngCel As Range, RngRow As Range
Dim i As Integer, rcnt As Integer
Dim Xsum As Long
Dim sht As Worksheet, tgt As Worksheet
Set sht = Sheets(“Data”)
sht.Select
‘ 취합할 데이터의 행의 수를 체크합니다.
rcnt = sht.Range(“A1”, Range(“A1”).End(xlDown)).Cells.Count
‘ 데이터 취합할 시트를 초기화 합니다.
For Each tgt In Worksheets
If tgt.Name = “X_Cnt_Row” Then
Application.DisplayAlerts = False
tgt.Delete
Application.DisplayAlerts = True
End If
Next
‘ 새 시트를 만듭니다.
Worksheets.Add.Name = “X_Cnt_Row”
‘ 행만큼 루프를 돌립니다.
For i = 1 To rcnt
‘ 영역을 열마다 재설정 합니다. 행의 제일 뒤에서 값이 나타날 때까지 취합니다.
Set RngRow = sht.Range(“B” & i, sht.Range(“B” & i).Offset(0, 256).End(xlToLeft))
‘ 취합할 데이터의 제목행을 새 시트로 옮깁니다
Sheets(“X_Cnt_Row”).Range(“A” & i).Value = RngRow.Offset(0, -1).Value
‘ 영역을 순환합니다.
For Each RngCel In RngRow
‘ 영역의 컬럼을 체크하여 필요없는 부분을 건너뜁니다.
If RngCel.Column / 2 <> 0 Then
‘ 영역과 비교하여 참값을 취하여 더해 줍니다
If UCase(RngCel.Offset(0, 1).Value) = “X” Then
Xsum = Xsum + RngCel.Value
End If
End If
Next RngCel
‘ 더해진 값을 취합 시트에 넣어줍니다.
Sheets(“X_Cnt_Row”).Range(“A” & i).Offset(0, 1).Value = Xsum
‘ 행의 더한 값을 초기화 시킵니다.
Xsum = 0
Next i
End Sub
주석 참고하시면 쉽게 이해하실 수 있을 것입니다. 만약에 “O” 마크를 찾고 싶으면 코드 중에서
if RngCel.Column / 2 <> 0 then 을 if RngCel.Column / 2 = 0 then로 바꾸시고 그 아래 코드를
If UCase(RngCel.Offset(0, 1).Value) = “X” Then의 “X”를 “O”로 바꾸시면 됩니다.
아래 코멘트처럼 간단하게 처리할 수도 있지만 VBA를 요청하셔서 올립니다.
첨부 화일 : 20151008-각 행별의 셀 패턴별 숫자 합치기
2월 17 2016
[엑셀] – 각 워크북의 특정 시트의 특정열 병합
오랜만에 자료 올리네요. 기존에 내용이 있어서 쉽게 만들 수 있었네요.
Option Explicit
Sub MergeWBs()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = “C:\Data”
Set wbDst = ThisWorkbook
strFilename = Dir(MyPath & “\*.xls”, vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = “”
Set wbSrc = Workbooks.Open(Filename:=MyPath & “\” & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy after:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub MergeWSs()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range
Dim colCount As Integer
Set wrk = ActiveWorkbook
Application.DisplayAlerts = False
For Each sht In wrk.Worksheets
If sht.Name = “Master” Or sht.Name = “ExtData” Then
sht.Delete
End If
Next sht
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Set trg = wrk.Worksheets.Add(after:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = “ExtData”
Set sht = wrk.Worksheets(1)
With trg.Cells(1, 1).Resize(1, 3)
.Value = sht.Cells(1, 1).Resize(1, 3).Value
.Font.Bold = True
.Interior.Color = vbGreen
End With
For Each sht In wrk.Worksheets
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
Set rng = sht.Range(sht.Cells(31, 1), sht.Cells(31, 1).Resize(, 4))
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, 3).Value = rng.Value
Next sht
trg.Activate
trg.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
차근 차근 읽어보시면 이해가 되실 것입니다.
첨부 : 20160217-각 워크북의 특정 시트의 특정열 병합
By vinipapa • 무른모 • 0 • Tags: 병합, 엑셀, 추출, 팁