マクロを記録して見ることで、すべてを理解することができます。追加の知識の平和があります。それは、「A1:G3」と言う代わりに、 Range( Cells(x,y), Cells(x,y) ) を使用して、たとえば実行できることです。
Range( Cells(1,1), Cells(1,3).Select
ActiveSelection.Copy ' or .Cut
[Excel のオプション] に移動し、[全般] タブで [R1C1 スタイルを使用] を選択します。エクセルは列にも数字を表示します。
空のセルは
IsEmpty( Cells(3,9) )
既存のシートを開くために
Sheets("All").Select
そう
dim currentService
currentService = Cells(i, 3) ' current row, 13'th column
Sheets(currentService).Select
つまり、次のようになります。フィルター関数を見つけてから、moveDown によってセルを反復処理します。
おそらく最も簡単な方法は、サービスでソートすることです。各サービスの開始行と終了行を見つけます。別の場所 (空ではない) に到達するまで行を繰り返します。各サービスの範囲全体をコピーします。そのサービスの正しい本を選択し、空の行を見つけます。そのサービス シート (各行のセルを読み取るか、いくつかのセルを確認する場合:
Function hasRowContent (rownum as Integer) as Boolean
Dim rowContentCheck
rowContentCheck = Cells(rownnum, 1) & Cells(rownum, 3) & Cells(rownnum, 7)
hasRowContent = rowContentCheck <> ""
Return
End Function
空行の数を数えます。コンテンツのない行が発生するたびに、emptyRows カウンターが増加します
emptyRows = emptyRows + 1
コンテンツに遭遇する各行で、emptyRows をゼロに戻し、ここからカウントを開始します。
If emptyRows > emptyRowsToStopAt
rowInServiceSheet = currentRow
コードの先頭...
dim emptyRowsToStop
dim emptyRows
For currentRow = 1 To 1000
編集：
私の最初の回答で説明されたすべてのコード
ここに行きます：
Public Function SheetExists(sheetName As String) As Boolean
' Sheet! It Exists
Dim wrkSheet As Worksheet
SheetExists = False
For Each wrkSheet In ThisWorkbook.Worksheets
If wrkSheet.Name = sheetName Then
SheetExists = True
Exit For
End If
Next
End Function
Sub createMissingServicePages()
' start on first cell in ALL
Sheets("all").Select
Row1.Select
Row1.Copy
Dim serviceTypes
serviceTypes = Array("Tree", "Graffiti", "Light", "Pothole")
Dim serviceTypeName As String
For Each serviceType In serviceTypes
serviceTypeName = serviceType
If Not SheetExists(serviceTypeName) Then
' create a new sheet - at the end of the Sheets list
Sheets.Add After:=Sheets(Sheets.Count) ' after 8
' and name it
Sheets(Sheets.Count).Name = serviceTypeName ' by now its 9
' select it and copy first row to it
'.. copy header row
Sheets("All").Select
Rows(1).Select
Rows(1).Copy
' .. paste in target sheet
Sheets(Sheets.Count).Select
Cells(1, 1).Select
ActiveCell.PasteSpecial xlPasteAll
End If
Next
End Sub
Sub updateServicePages()
' if you wish to see the column numbers rather than letters
' change settings in Options / GENERAL tab to View R1C1 style
Call createMissingServicePages
' start on first cell in ALL
Sheets("all").Select
Cells(1, 1).Select
' We'll need this later:
' count the columns
Dim columnsCount As Integer
For Each aCell In Rows(1).Cells
If IsEmpty(aCell) Then
columnsCount = aCell.Cells.Column
Exit For
End If
Next
' get TypeOfService column number
Dim serviceTypeHeaderText As String
Dim serviceTypeColumnnum As Integer
serviceTypeHeaderText = "type of service" ' ignoring case...
Cells.Find(What:=serviceTypeHeaderText, _
After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
serviceTypeColumnnum = ActiveCell.Column
' sort the whole range
Cells.Select ' first select the whole range
' unremark next line of code if you want to format the data nicely...
'Cells.EntireColumn.AutoFit ' if we are already at it
Selection.Sort Key1:=Cells(1, serviceTypeColumnnum), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' now move the data for each typeofService
Dim serviceTypes
Dim serviceTypeName As String
serviceTypes = Array("Tree", "Graffiti", "Light", "Pothole")
Dim rangeStart As Integer
Dim rangeEnd As Integer
For Each serviceType In serviceTypes
' we reset for each serviceType
Sheets("all").Select
Cells(1, 1).Select
rangeStart = 0
rangeEnd = 0
serviceTypeName = serviceType
' .. find range start and end
For Each aRow In Rows
If aRow.Cells(serviceTypeColumnnum) = serviceTypeName Then
If rangeStart = 0 Then rangeStart = aRow.Cells.Row
Else
If rangeStart <> 0 Then ' we just exited the range
rangeEnd = aRow.Cells.Row - 1
Exit For ' done with this serviceType range
Else ' didn't reach our range yet
End If
End If
Next ' row
' No 'continue' in VBA... and don't want to use a GOTO
' If rangeStart = 0 Or rangeEnd = 0 Then 'continue for
If rangeStart <> 0 And rangeEnd <> 0 Then
' .. now copy serviceType to correct sheet
Dim servicetypeRange As Range
Set servicetypeRange = Range(Cells(rangeStart, 1), Cells(rangeEnd, columnsCount))
servicetypeRange.Select
servicetypeRange.Copy
' find empty row in target sheet
Sheets(serviceTypeName).Select
Dim emptyrowNum As Integer
Dim emptyrowCount As Integer
Dim emptyrowMax As Integer
Dim emptyrowMargin
emptyrowMax = 5 ' set this to 1 if there are no spaces in the data
emptyrowMargin = 0 ' change this if you want an empty row between last data and new data
For Each aRow In Rows
If IsEmpty(aRow.Cells(1)) Then ' you could check over a few cells by: & isEmpty(aRow.Cells(2)) etc.
emptyrowCount = emptyrowCount + 1
If emptyrowCount > emptyrowMax Then
emptyrowNum = aRow.Row - emptyrowCount ' last empty row
If emptyrowNum < 1 Then emptyrowNum = 1
emptyrowNum = emptyrowNum + emptyrowMargin
Exit For ' we found empty row
End If
End If
Next
Cells(emptyrowNum, 1).Select
ActiveCell.PasteSpecial xlPasteAll ' ,skipBlanks if needed
End If
Next ' serviceType
Sheets("All").Select
Cells(1, 1).Select
MsgBox "Done!"
End Sub