"Worksheet_Change" overwrites relocated rows and cannot handle gaps between columns

I want to write a piece of VBA code in Sheet1 which reacts to changes made in a drop-down list in Excel.

For now, I have written the following code where Zeile = Row and every relevant entry in the drop-down list can be found within the range of K7:K1007. When set to C (= Completed), the respective row shall be relocated to another sheet, called Completed Items.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Zeile As Long
    Set Target = Intersect(Target, Range("K7:K1007"))
    If Target Is Nothing Then Exit Sub
    If Target = "C" Then
        Zeile = Target.Row
        Range(Range(Cells(Zeile, 1), Cells(Zeile, 11)), _
        Range(Cells(Zeile, 14), Cells(Zeile, 17))).Copy _
        Destination:=Sheets("Completed Items").Cells(Rows.Count, 1).End(xlUp).Offset(6, 0)
        Target.EntireRow.Delete
    End If
End Sub

Moving a row from Sheet1 to a sheet called Completed Items works. But there are, however, still some problems left.

Overwriting relocated rows all the time

When initiating the sequence, the respective row is moved from Sheet1 to row 7 in Completed Items. Moving another row, however, will result in overwriting row 7 in Completed Items. Why is that? I have tried to change the Offset() option, but nothing has worked out so far.

VBA cannot handle the gap between column `11` and `14`

I just want to relocate columns 1 to 11 and 14 to 17 from Sheet1 to Completed Items so that everything in that range from Sheet1 is relocated to columns 1 to 15 in Completed Items. That, however, does not work and all columns (1 to 17) from Sheet1 are relocated to Completed Items. What is wrong?

Solution

Overwriting relocated rows all the time

You are determining the row to copy to by Cells(Rows.Count, 1).End(xlUp), which means the last cell in column A. Is it possible that the first cell in the copied row is empty?

To find the last row with data in any column there are multiple ways. The most reliable I have found is to use .Find to search for the last cell containing anything.

Function findLastRow(sh As Worksheet) As Long
    Dim tmpRng As Range 'need to use temporary range object in case nothing is found. (Trying to access .Row of Nothing causes error)

    Set tmpRng = sh.Cells.Find(What:="*", _
        After:=sh.Cells(1), _
        LookIn:=xlValues, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious)
    If Not tmpRng Is Nothing Then
        findLastRow = tmpRng.Row
    Else
        findLastRow = 1
    End If
End Function

Using UsedRange is easier but might be unreliable because it might not reset after deleting cell contents.

VBA cannot handle the gap between column 11 and 14

Range(X,Y) returns the smallest rectangular range that contains both X and Y so in your case it's the same as Range(Cells(Zeile, 1), Cells(Zeile, 17))

btw, you should specify the sheet in this case like you do with the destination.

As @bobajob already said, you can create ranges with multiple regions using Union, i.e. use Union(Range(Cells(Zeile, 1), Cells(Zeile, 11)), Range(Cells(Zeile, 14), Cells(Zeile, 17))).Copy

Another way to create it would be using the address (for example "A1:K1,N1:Q1" for the first row):

Range("A" & Zeile & ":K" & Zeile & ",N" & Zeile & ":Q" & Zeile).Copy

However it is often better to avoid copying and pasting (it's slow) and just write the values directly. In your case it could be done with

Dim sh1 As Worksheet  'where to copy from
Dim sh2 As Worksheet  'where to copy to
Dim zielZeile As Long 'which row to copy to

Set sh1 = ThisWorkbook.Worksheets("sheetnamehere")
Set sh2 = ThisWorkbook.Worksheets("Completed Items")

'...
'set the row where to copy
zielZeile = findLastRow(sh2) + 6
'write to columns 1 to 11
sh2.Range(sh2.Cells(zielZeile, 1), sh2.Cells(zielZeile, 11)).Value = sh1.Range(sh1.Cells(Zeile, 1), sh1.Cells(Zeile, 11)).Value
'write to columns 12 to 115
sh2.Range(sh2.Cells(zielZeile, 12), sh2.Cells(zielZeile, 15)).Value = sh1.Range(sh1.Cells(Zeile, 14), sh1.Cells(Zeile, 17)).Value