CODEWITHSUNDEEP
vbaexcelspreadsheetcopy-paste
Veronika Rosales
Veronika Rosales

Reputation: 35

Copy specific cells from sertain rows from Sheet 1 depending on non-zero value in column to the last empty row of Sheet 2

I feel bad asking this silly question, but I'm not able to copy some data from multiple rows in Sheet 1 to Sheet 2 based on the value in column H Sheet 1.

If in Column H (Sheet1) entered any integer (positive or negative)

In Sheet2 starting from row 7

Column A = Date

Column B = Column B (Sheet1)

Column C = Column c (Sheet1)

Column D = Column D (Sheet1)

Column E = Column E (Sheet1)

Column F = Colunb F (Sheet1)

Column G = Column H (Sheet1)

Here is my code:

 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

I feel like what I do is completely wrong because I have no idea how, but this code edits columns 8 and 7 in WorkSheet1 (randomly adds the date there xD). And in Sheet2 it creates a mess (copies extra data that does not have any integer in row H offsetting it by 6 down from the last inserted cell) =/

This question might be silly, but I have spent lot's of time today trying to solve it and realized that I'm not able to do it on my own. Lots of thanks for any help. =)

Upvotes: 0

Views: 1550

Answers (1)

Tim Williams
Tim Williams

Reputation: 166381

Something like this:

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

Upvotes: 1

Related Questions