需要在下一個空白區域粘貼信息

使用此代碼，它將複製數據並將其粘貼到該名稱所屬的相應相應選項卡上，但是當我再次運行它以用於下一組數據時，最後的數據。我不知道如何空話貼添加到下一個空行需要在下一個空白區域粘貼信息

Dim c As Range, namesRng As Range 
    Dim name As Variant 

    With Worksheets("DRIVERS") '<--| reference "DRIVERS" worskheet 
     Set namesRng = .Range("A2", .Cells(.Rows.Count, "a").End(xlUp)) '<--| set the range of "drivers" in column "a" starting from row 4 down to last not empty row 
    End With 

    With CreateObject("Scripting.Dictionary") '<--| instance a 'Dictionary' object 
     For Each c In namesRng.SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through "drivers" range cells with text content only 
      .Item(c.Value) = c.Value '<--| build the unique list of names using dictionary key 
     Next 
     Set namesRng = namesRng.Resize(namesRng.Rows.Count + 1).Offset(-1) '<--| resize the range of "names" to have a "header" cell (not a name to filter on) in the first row 
     For Each name In .Keys '<--| loop through dictionary keys, i.e. the unique names list 
      FilterNameAndCopyToWorksheet namesRng, name '<--| filter on current name and copy to corresponding worksheet 
     Next 
    End With '<--| release the 'Dictionary' object 
End Sub 

Sub FilterNameAndCopyToWorksheet(rangeToFilter As Range, nameToFilter As Variant) 
    Dim destsht As Worksheet 

    Set destsht = Worksheets(nameToFilter) '<--| set the worksheet object corresponding to passed name 
    With rangeToFilter 
     .AutoFilter Field:=1, Criteria1:=nameToFilter 
     Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy destsht.Cells(destsht.Rows.Count, "a").End(xlUp) 
     .Parent.AutoFilterMode = False 

    End With 
End Sub

來源

2017-08-17 Doug Gilmer

當提出與代碼相關的問題時，爲您使用的特定語言添加標籤總是明智的。 *複製*和*粘貼*自己幾乎沒用。請[edit]在你的問題中包含適當的語言標籤（excel-vba，它會出現）。你還應該解釋你發佈的代碼如何不適合你。現在看來，這是一個*請爲我寫*代碼後，我們不是一個代碼寫作服務。謝謝。 –

對不起，肯我第一次在論壇上問過。我會糾正verbage –

沒問題。建議的話 - 這不是一個論壇，當你把它稱爲一個時，人們不喜歡它。 *論壇*意味着一個社交網站的討論，這絕對不是這樣一個網站。這完全是一個問題和答案網站。您可能需要花點時間參加[導覽]並閱讀[幫助]頁面。 –

destsht.Cells(destsht.Rows.Count, "a").End(xlUp)

在上面的代碼只需添加偏移（）到底。

destsht.Cells(destsht.Rows.Count, "a").End(xlUp).Offset(1)

來源

2017-08-17 04:35:25 Sixthsense

需要在下一個空白區域粘貼信息

回答

相關問題