根据表1中的非零值复制Sheet 1中某些行的特定单元格到She​​et 2的最后一个空行

我不好意思问这个愚蠢的问题，但是我不能根据H表1中的值将Sheet 1中的多行数据复制到Sheet 2中。

如果在H栏（Sheet1）中input任何整数（正数或负数）

在Sheet2从第7行开始

A列=date

B列= B列（Sheet1）

列C =列c（Sheet1）

D列= D列（Sheet1）

E列= E列（Sheet1）

F栏= Colunb F（Sheet1）

G列= H列（Sheet1）

这是我的代码：

Private Sub Transfer_Click() Application.ScreenUpdating = False j = 0 'set j = # of units to transfer Do While Counter < 8 ' Inner loop. Counter = Counter + 1 ' Increment Counter. If Cells(10, Counter).Value = "# of units to transfer" Then j = Counter End If Loop If j <> 0 Then For i = 11 To 1500 If Cells(i, j).Value = 0 Then Next i ElseIf Cells(i, j).Value <> 0 Then If OptionButton1 = True Then Sheet2.Select Sheet2.Range("A1").Select If Sheet2.Range("A1").Offset(1, 0) <> "" Then Sheet2.Range("A1").End(xlDown).Select End If End If End If ActiveCell.Offset(6, 0).Select 'Date column A ActiveCell.Value = Date ActiveCell.Offset(0, 1).Select 'copy Code ActiveCell.Value = Sheet1.Cells(i, 2).Value ActiveCell.Offset(0, 1).Select 'Copy Bar Code ActiveCell.Value = Sheet1.Cells(i, 3).Value ActiveCell.Offset(0, 1).Select 'Copy articul ActiveCell.Value = Sheet1.Cells(i, 4).Value ActiveCell.Offset(0, 1).Select 'Copy product name ActiveCell.Value = Sheet1.Cells(i, 5).Value ActiveCell.Offset(0, 1).Select 'Copy product unit ActiveCell.Value = Sheet1.Cells(i, 6).Value ActiveCell.Offset(0, 1).Select 'copy products on hands ActiveCell.Value = Sheet1.Cells(i, 8).Value Next i End If Application.ScreenUpdating = True End Sub 

我觉得我所做的是完全错误的，因为我不知道该怎么做，但是这段代码在WorkSheet1中编辑了第8列和第7列（随机添加了xD的date）。 并在Sheet2中创build一个混乱（复制额外的数据，在H行没有任何整数抵消它从最后插入的单元格6）= /

这个问题可能是愚蠢的，但我今天花了很多时间试图解决它，并意识到我无法自己做。 非常感谢您的帮助。 =）

Answer 1

像这样的东西：

 Private Sub Transfer_Click() Dim j As Long, i As Long, f As Range, c As Range Dim sht As Worksheet 'look for the header on row 10 Set f = Sheet1.Rows(10).Find("# of units to transfer", lookat:=xlWhole) If f Is Nothing Then MsgBox "Header not found!", vbExclamation Else 'copy to which sheet? If Me.OptionButton1 Then Set sht = Sheet2 ElseIf Me.OptionButton2 Then Set sht = Sheet3 End If 'find the first empty row Set c = sht.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) Application.ScreenUpdating = False j = f.Column For i = 11 To 1500 If Sheet1.Cells(i, j) <> 0 Then 'transfer the data c.Value = Date c.Offset(0, 1).Resize(1, 5).Value = _ Sheet1.Cells(i, 2).Resize(1, 5).Value c.Offset(0, 6).Value = Sheet1.Cells(i, 8).Value Set c = c.Offset(1, 0) 'next row End If Next i Application.ScreenUpdating = True End If 'found header End Sub