2012-06-07 41 views
2

我需要Excel 2010中的VBA幫助來編寫宏。根據列中的條件複製行的範圍,並粘貼到名爲條件的另一個表中

我需要知道如何根據一列中的條件複製特定範圍的行,並將包含該指定標準的每一行(整行,所有其他字段)粘貼到其相應的工作表(將在後面解釋)。困難的部分是那些「目標」表可能已經有一些數據需要駐留在那裏而不被刪除。那麼,我如何編寫一個宏來完成我剛剛描述的內容,但是當它粘貼時,它會找到第一個空行開始粘貼?

我有一個約5張工作簿。第一張是包含所有數據的ALL工作表。接下來的4張被命名爲Tree,Graffiti,LightPothole。所有5個工作表中的所有字段都是相同的。在每張表中,有一個稱爲Type Of Service的字段,即這四個服務之一(tree,graffiti,lightpothole)。

我需要做的是爲這4個服務(每次一個)過濾ALL工作表,選擇包含指定服務的所有字段和所有行,將其全部複製並粘貼放入其單張表格中。這些單獨的工作表可能包含一些數據,因此粘貼需要找到第一個空行並將其粘貼到那裏。按原樣連接工作表和ALL工作表中的複製行。我需要宏將所有4個服務過濾器/粘貼在一起。

回答

1

你可以通過錄制宏觀來了解一切。 有知識的一個額外的和平,這是不是說 「A1:G3」 可以使用範圍(單元格(X,Y),電池(X,Y)) 和例如

Range(Cells(1,1), Cells(1,3).Select 
ActiveSelection.Copy ' or .Cut 

做轉到Excel選項並在常規選項卡上選擇USE R1C1樣式。 excel也顯示列上的數字。

空細胞被

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 
相關問題