Incorrect copying of columns

Question

I am trying to create some VBA code,for excel, that will allow me to copy data from a number of products into a new sheet with the same name as the product. The different data for each product is separated by one column of dates which are not copied into the new sheet. I have created the following code and it works for one product, however when I add a second product the code goes wrong. Instead of copying the first column from the 2nd product it copies the third column from the previous product again then jumps straight to the second column of the second product. So the code leaves out the full first column of the second product.

Sub Forecast_Products()
 Dim iterations As Integer
 iterations = Cells(68, 1).Value
 Dim i As Integer, j As Integer
 For i = 1 To iterations
    Cells(69, i).Value = 0
    For j = 2 To 6 Step 2
        Dim startCell As String, endCell As String
        startCell = Col_Letter(j + 7 * (i - 1)) & "9"
        endCell = Col_Letter(j + 7 * (i - 1)) & "60"
        Range(startCell, endCell).Select
        Dim salesCount As Integer
        salesCount = Cells(69).Value
        Cells(69).Value = salesCount + Application.WorksheetFunction.CountIf(Range(startCell, endCell), ">=0")
        Selection.Copy
        Dim productName As String
        Sheets("Input").Activate
        productName = Cells(70, i).Value
        MsgBox (productName & " 70, " & CStr(i))
        Sheets(productName).Activate
        Dim rowStart As Variant
        rowStart = CStr(11 + (52 * (j / 2 - 1)))
        Range("B" & rowStart).Select
        Selection.PasteSpecial xlValue
        Range("M" & rowStart).Select
        Selection.PasteSpecial xlValue
        Sheets("Input").Activate
    Next
    Dim rowCount As Integer
    rowCount = Cells(69, i).Value + 10
    Sheets(Cells(70, i).Value).Activate
    For j = 4 To 8
        Dim formula As Variant
        formula = Cells(17, j).Copy
        startCell = Col_Letter(j) & "18"
        endCell = Col_Letter(j) & CStr(rowCount)
        Range(startCell, endCell).Select
        Selection.PasteSpecial xlAll
    Next
Next

End Sub

Function Col_Letter(lngCol As Integer) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function

Is this related to Excel, or are you using VBA with some other piece of code that has sheets, ranges, cells, and selections? — John Saunders, Jan 11 '15 at 02:46
Sorry yes I am using the code with excel forgot to mention that. — Lucas Schieder, Jan 11 '15 at 09:41
First things first: you need to eliminate use of `Select`, `Activate` etc. once these are removed logic errors will become much more apparent (and the code I'll be much more efficient). [see this question](http://stackoverflow.com/q/10714251/445425) — chris neilsen, Jan 11 '15 at 10:34

score 1 · Answer 1 · answered Jan 11 '15 at 10:30

Figured the problem out. The first loop for the 2nd product didn't go back to the input sheet. This is the fixed code.

Sub Forecast_Products()
 Dim iterations As Integer
 iterations = Cells(68, 1).Value
 Dim i As Integer, j As Integer
 For i = 1 To iterations
    Cells(69, i).Value = 0
    For j = 2 To 6 Step 2
        Dim startCell As String, endCell As String
        startCell = Col_Letter(j + 6 * (i - 1)) & "9"
        endCell = Col_Letter(j + 6 * (i - 1)) & "60"
        Sheets("Input").Activate
        Range(startCell, endCell).Select
        Dim salesCount As Integer
        salesCount = Cells(69).Value
        Cells(69).Value = salesCount + Application.WorksheetFunction.CountIf(Range(startCell, endCell), ">=0")
        Selection.Copy
        Dim productName As String
        Sheets("Input").Activate
        productName = Cells(70, i).Value
        'MsgBox (productName & " 70, " & CStr(i))
        Sheets(productName).Activate
        Dim rowStart As Variant
        rowStart = CStr(11 + (52 * (j / 2 - 1)))
        Range("B" & rowStart).Select
        Selection.PasteSpecial xlValue
        Range("M" & rowStart).Select
        Selection.PasteSpecial xlValue
        Sheets("Input").Activate
    Next
    Dim rowCount As Integer
    rowCount = Cells(69, i).Value + 10
    Sheets(Cells(70, i).Value).Activate
    For j = 4 To 8
        Dim formula As Variant
        formula = Cells(17, j).Copy
        startCell = Col_Letter(j) & "18"
        endCell = Col_Letter(j) & CStr(rowCount)
        Range(startCell, endCell).Select
        Selection.PasteSpecial xlAll
    Next
Next

End Sub

Function Col_Letter(lngCol As Integer) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function

Incorrect copying of columns

1 Answers1