|
* 답변하시는 분들께 도움이 되도록 자신의 환경을 아래 항목 옆에 기재해 주세요.
- 엑셀 버전(95,97,2000,xp,2003,2007):
* 아래줄에 질문을 작성하세요 >>
날짜(30,31일까지 있음)별로 이름을 한셀에 표기하고, 장소별로 시트를 만들수 있을까요?
==============[카스님 글에 대한 답변입니다]==============
첨부파일 참고하세요..
Sub CreateEachSheet()
Dim sht As Worksheet, shtTmp As Worksheet
Dim rData As Range, rRow As Range
Dim rFind As Range, rTg As Range
Dim sAddr As String
Dim bFlg As Boolean
Set sht = ActiveSheet
Set rData = sht.Range("A1").CurrentRegion
For Each rRow In rData.Offset(1).Resize(rData.Rows.Count - 1).Rows
Set shtTmp = getSheet(rRow.Cells(1, 3))
If shtTmp.Cells(1, 1) = "" Then
rData.Rows(1).Copy shtTmp.Cells(1)
End If
bFlg = False
Set rFind = shtTmp.Columns(1).Find(What:=rRow.Cells(1, 1), LookAt:=xlWhole)
If Not rFind Is Nothing Then
If InStr(rFind.Cells(1, 2), rRow.Cells(1, 2)) > 0 Then
Else
rFind.Cells(1, 2) = rFind.Cells(1, 2) & "," & rRow.Cells(1, 2)
End If
Else
Set rTg = shtTmp.Cells(Rows.Count, 1).End(xlUp).Offset(1)
rRow.Copy rTg
End If
Next
End Sub
Function getSheet(SheetName As String)
Dim shtX As Worksheet
On Error Resume Next
Set getSheet = ThisWorkbook.Sheets(SheetName)
If Err.Number <> 0 Then
ThisWorkbook.Worksheets.Add After:=Sheets(Sheets.Count)
Set getSheet = ActiveSheet
getSheet.Name = SheetName
End If
On Error GoTo 0
End Function
|
|