도움을 받으시기 바랍니다. 아래 코드가 있습니다. 본질적으로 그것이하는 일은 사용자가 Excel 시트를 선택할 수있는 대화 상자를 연 다음 국가 컬럼 (11)으로 이동하여 필터 한 다음 해당 국가를 복사하여 새 통합 문서에 붙여넣고 새 통합 문서의 이름을 지정합니다 그런 다음 그 국가가 다음 국가에 대한 조치를 반복하면 각 통합 문서를 저장하고 닫습니다.열의 특정 셀이 비어있는 경우에만 복사하여 붙여 넣기
코드는 완벽하게 작동하지만, 지금은 셀이 있거나 머리글 아래의 A, B 또는 C 열에 두 개의 셀 또는 세 개의 셀이 비어 있으면 코드를 수행하려고합니다. 각 행에 해당 행을 복사하여 붙여 넣기 만하면됩니다.
그래서 아래 그림에서 셀 A5가 비어있는 것을 보겠습니다.이 행을 복사하여 벨기에 통합 문서에 넣고 가면서 계속가 봅니다. 셀 A14는 비어 있습니다. 이 행과 불가리아 통합 문서에 넣어, 아 C17 셀이 행을 복사하고 불가리아 통합 문서에 넣어. Ah Cell A26, B26 및 C26은이 행을 공백으로 복사하여 크로아티아 통합 문서에 넣습니다.
언제나 도움을 주시면 대단히 감사하겠습니다.
여기 여기
Sub Open_Workbook_Dialog()
Dim my_FileName As Variant
Dim my_Workbook As Workbook
MsgBox "Pick your CRO file" '<--| txt box for prompt to pick a file
my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection
If my_FileName <> False Then
Set my_Workbook = Workbooks.Open(Filename:=my_FileName)
Call Filter(my_Workbook) '<--|Calls the Filter Code and executes
End If
End Sub
Public Sub Filter(my_Workbook As Workbook)
Dim rCountry As Range, helpCol As Range
Dim wb As Workbook
With my_Workbook.Sheets(1) '<--| refer to data worksheet
With .UsedRange
Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in
End With
With .Range("A1:Y" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Y" from row 1 to last non empty row of column "A"
.Columns(11).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 11th column of the referenced range and store its unique values in "helper" column
Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row)
For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row)
.AutoFilter 11, rCountry.Value2 '<--| filter data on country field (11th column) with current unique country name
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
Set wb = Application.Workbooks.Add '<--... add new Workbook
wb.SaveAs Filename:=rCountry.Value2 '<--... saves the workbook after the country
.SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Range("A1")
ActiveSheet.Name = rCountry.Value2 '<--... rename it
.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header
Sheets(1).Range("A1:Y1").WrapText = False 'Takes the wrap text off
ActiveWindow.Zoom = 55
Sheets(1).UsedRange.Columns.AutoFit 'Autofits the column
wb.Close SaveChanges:=True '<--... saves and closes workbook
End If
Next
End With
.AutoFilterMode = False '<--| remove autofilter and show all rows back
End With
helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included)
End Sub
루프 국가 별 필터를 먼저 완료하고 확인하기 위해 필요하지 않은 경우 필요는 없습니다 각 행의 국가 이름은 하나의 특수 셀 세트로 복사하여 붙여 넣을 수 있어야합니다. –
@Mak : 도움을 주셔서 감사합니다. 내가 제공 한 코드를 사용해보고 싶지만 기존 코드에서이 새로운 코드를 어디에 배치할까요? –
@PhilipConnell : 이미 답변을 변경 했으므로 복사 코드를 교체하십시오. 그렇지 않으면 마침내 넣으십시오. – Mak