728x90
Dim lastrow As Long
Dim lngE As Long
Dim rngD As Range
Dim i As Long
Dim j As Long
Dim Data As Long
Dim xLastRow As Long
Dim RealDataLastRow As Long
Dim DeletedWantedRow As Long
Dim LastLoopIndex As Long
Dim co As Long
Dim incRow As Long
Dim k As Long
Dim LastDateTime As Long
Dim xWs As Worksheet
lastrow = Sheets("20210421").Cells(Rows.Count, "F").End(xlUp).Row
Sheets("20210421").Range("F2:F" & lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet1").Range("B5"), _
Unique:=True
'DIstinct Part
'Dintct 된 데이터 갯수만큼의 전처리시트가 필요
xLastRow = Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row - 4
' 6 제대로 나왔음 -> 데이터의 총 갯수
For j = 1 To xLastRow
' 1 2 3 4 5 6
lngE = Sheets("20210421").Cells(Rows.Count, "F").End(xlUp).Row
For i = 2 To lngE
If Sheets("20210421").Range("F" & i).Value = Sheets("Sheet1").Range("B" & (4 + j)).Value Then
If rngD Is Nothing Then
Set rngD = Sheets("20210421").Range("F" & i).Offset(0, -5).Resize(1, 6)
Else
Set rngD = Union(rngD, Sheets("20210421").Range("F" & i).Offset(0, -5).Resize(1, 6))
End If
End If
Next
If rngD Is Nothing Then
MsgBox "복사할 범위가 없습니다."
Else
Sheets.Add after:=Sheets(2 + j)
Sheets(3 + j).Range("A1").CurrentRegion.Offset(1, 0).Clear
rngD.Copy Sheets(3 + j).Range("A1")
End If
'시트를 추가하고 데이터 사전 전처리
co = Sheets(3 + j).Range("F1").CurrentRegion.Rows.Count
For incRow = 0 To co
If Sheets("Sheet1").Range("B" & (4 + j)).Value <> Sheets(3 + j).Cells(1, "F").Offset(0, 0).Value Then
'시트와 데이터를 비교
Sheets(3 + j).Range("F1").Select
Selection.EntireRow.Delete
End If
Next
'데이터 사전가공 완료
Next
For k = 1 To xLastRow
LastDateTime = Sheets(3 + k).Cells(Rows.Count, "B").End(xlUp).Row
'모든 시트의 D1에는 데이터가 있음
Sheets(3 + k).Activate
Range("D1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
' 카피부
Sheets("Sheet1").Activate
Cells(5, "E").Offset(k - 1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Sheet1").Cells(4 + k, "C").Offset(0, 0).Value = Sheets(3 + k).Range("B1").Value
Sheets("Sheet1").Cells(4 + k, "D").Offset(0, 0).Value = Sheets(3 + k).Range("B" & LastDateTime).Value
Next
'마무리 처리
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Sheet1" And xWs.Name <> "20210421" And xWs.Name <> "Sheet2" Then 'Sheet1 과 남길시트이름 두개만 남기고 모두 삭제됨
xWs.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheets("Sheet1").Activate'VBA' 카테고리의 다른 글
| [VBA] Specific Data Distraction (0) | 2021.04.23 |
|---|---|
| [VBA] last Data Cell Searching (0) | 2021.04.23 |
| [VBA] Sheet.Add and Sheet.Delete Method (0) | 2021.04.23 |
| [VBA] Specific Data Deleting (0) | 2021.04.23 |
| Sheet Deleting except specific sheet (0) | 2021.04.23 |
