Sub aa()
'聲明Excel相關
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Set xlApp = New Excel.Application
Dim country() As String
For i = 1 To ActiveWorkbook.Sheets("國家").UsedRange.Rows.count
If ActiveWorkbook.Sheets("國家").Cells(i, 1) = "" Then
Exit For
End If
ReDim Preserve country(1 To i)
country(i) = ActiveWorkbook.Sheets("國家").Cells(i, 1).value
Next
xx:
' Set xlBook = xlApp.Workbooks.Open("C:/Documents and Settings/alex/桌面/合併的國家統計數據.xlsx")
Dim count As Integer
count = ActiveWorkbook.Worksheets.count
'遍歷sheet
For i = 1 To count '
If ActiveWorkbook.Worksheets(i).Name <> "國家" Then
Dim sheet As Excel.Worksheet
Set sheet = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.count))
sheet.Name = ActiveWorkbook.Worksheets(i).Cells(1, 1)
Dim k As Integer
k = 1
'開始遍歷
Dim beginSeek As Boolean
beginSeek = False
For j = 1 To ActiveWorkbook.Worksheets(i).UsedRange.Rows.count
If Not beginSeek Then
ActiveWorkbook.Worksheets(i).Rows(j).Copy
'xlBook.Worksheets(i).Cells(j, 1).EntireRow.Select
' Selection.Copy
' sheet.PasteSpecial
sheet.Cells(k, 1).PasteSpecial
k = k + 1
Else
Dim finded As Boolean
finded = False
finded = findArray(country, ActiveWorkbook.Worksheets(i).Cells(j, 1).value)
If finded Then
ActiveWorkbook.Worksheets(i).Rows(j).Copy
sheet.Cells(k, 1).PasteSpecial
k = k + 1
End If
End If
If Trim(ActiveWorkbook.Worksheets(i).Cells(j, 1).value) = "國家和地區" Then
beginSeek = True
End If
Next
End If
Next
' xlBook.Close
' Set sheet = xlBook.Worksheets(2)
End Sub
Function findArray(a() As String, value As String) As Boolean
Dim b As Boolean
b = False
If value = "" Then
b = True
Else
For i = 1 To UBound(a)
If a(i) = value Then
b = True
Exit For
End If
Next
End If
findArray = b
End Function
該方法有缺點，就是有合併單元格，拷貝出問題
