根據值將行復制到特定工作表

-1

不知道是否有人可以將我指向正確的方向，因爲我對每種方法都感到困惑。我已經搜索了很多答案，但我的情況與我發現的其他人有點不同。根據值將行復制到特定工作表

我有一個數爲每列列和標題的工作表。列A是「日期」，列B是「分類」，列C是「選擇」。還有更多的專欄。

我想要做的就是通過從A2到C列最後一行基地看A列的每個組行要複製的整個表圈。有可能是在列A中的日期之間的空行對於A列中每一組的行（日期到下一個日期-1行）我想基於列B.該範圍或行復制到不同的片

我已經編寫了代碼來移除列B引用的工作表，然後添加工作表並添加標題。

下面是一個例子：使用空以表明空單元

+------------+----------------+------------+ 
| Date  | Classification | Selection | 
+------------+----------------+------------+ 
| 10/08/2017 | Chris   | Selection1 | 
+------------+----------------+------------+ 
| 11/08/2017 | Chris   | Selection2 | 
+------------+----------------+------------+ 
| null  | null   | Selection3 | 
+------------+----------------+------------+ 
| null  | null   | Selection4 | 
+------------+----------------+------------+ 
| 11/08/2017 | Speed   | Selection5 | 
+------------+----------------+------------+ 
| null  | null   | Selection6 | 
+------------+----------------+------------+ 
| null  | null   | Selection7 | 
+------------+----------------+------------+

以上有3「記錄」需要被複制到2片材。 2個範圍到克里斯和1個範圍到速度。實際上，我有數百個需要移動到10張以上的「記錄」。基本上我必須爲每個記錄更新2張，我想只更新一個主人並讓Excel爲我完成複製工作。

感謝您的任何幫助

來源

2017-08-14 David Janes

好的選擇表是你的輸入，你可以做一個輸出的例子嗎？我並沒有真正理解這一切 – danieltakeshi

您可以發佈迄今爲止已經嘗試的代碼，以便我們可以提供具體的反饋嗎？ –

這似乎工作，但我猜測有一個更好的辦法！

Private Sub MoveThem() 
Dim sws As Worksheet 
Dim tws As Worksheet 
Dim cel As Range 
Set sws = Sheets("ALLSelections") 
Dim selectionTop, selectionBottom As Integer 
Dim sNm As String 
Dim lCol As Long 
Dim currentRow As Long 

selectionTop = 0 
selectionBottom = 0 

'~~> Get the last row and last column 
lRow = sws.Range("C" & sws.Rows.Count).End(xlUp).Row 
lCol = sws.Cells(1, sws.Columns.Count).End(xlToLeft).Column 

For currentRow = 2 To lRow 
    If sws.Cells(currentRow, 1) > 1 Then 

     If selectionTop = 0 Then 
      selectionTop = currentRow 

      ' Get the new sheet name 
      sNm = sws.Cells(currentRow, 2).Value 
      If Not WksExists(sNm) Then 
       ' If not already created then add to Misc 
       sNm = "Misc" 
      End If 
      Set tws = Sheets(sNm) 
     End If 
    End If 

    ' Check out the next row 
    If Len(sws.Cells(currentRow, 1).Offset(1)) <> 0 Then 
     If selectionTop <> 0 And selectionBottom = 0 Then selectionBottom = currentRow 
    End If 

    If currentRow = lRow Then selectionBottom = currentRow 

    If selectionTop <> 0 And selectionBottom <> 0 Then 
     ' We know know the range of rows 
     sws.Range("A" & selectionTop, "I" & selectionBottom).Copy tws.Range("A" & tws.Range("C" & Rows.Count).End(xlUp).Offset(1).Row) 
     selectionTop = 0 
     selectionBottom = 0 
    Else 

    End If 

Next 
MsgBox ("Complete") 
End Sub

來源

2017-08-15 12:39:55

根據值將行復制到特定工作表

回答

相關問題