Excel VBA: Loop through cells on another column basing on the first row

Question

I'm currently creating an automation that will separate the fruits for each store. Basically my file looks like below:

What I need to do is to transfer all fruits of Store X and B to column F (all fruits from different stores). The number of stores could grow as well as the fruits.

I have the code below, however, it only gets the first fruit and jump in to the next store already.

Sub test()
    Dim i, lastrow As Long
    lastrow = ActiveSheet.Cells(Worksheets(1).Rows.Count, "A").End(xlUp).Row 

    For i = 2 To lastrow
        Cells(i, 1).Select

        If Cells(i, 1).Value <> "" Then
            Cells(i, 6) = Cells(i, 4).Value
        End If
    Next i
End Sub

I'm thinking to add another lastrow count for the fruits, however, it just continues until the last row of column D.

Note that if you declare `Dim i, lastrow As Long` only `lastrow` is `Long` but `i` automatically becomes `Variant`. In VBA you need to specify a type for **every** variable: `Dim i As Long, lastrow As Long` — Pᴇʜ, Jul 26 '18 at 11:48
Thanks for the info Peh. For the stores, it can grow to some numbers. That's why I decided for it to find the lastrow for the stores. — Sevpoint, Jul 26 '18 at 11:52
So it is always: first store goes to column F, second store goes to column G, third to H and so on? — Pᴇʜ, Jul 26 '18 at 11:55

Pᴇʜ · Answer 1 · 2018-07-26T12:17:05.143

1

I suggest the following:

Option Explicit

Public Sub CopyFruitsIntoStores()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.ActiveSheet 'if this code is for a specific sheet only then better define a sheet like Thisworkbook.Worksheets("NameOfSheet")

    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row 'find last row in col D it is longer than A

    Dim iStore As Long 'to count the stores

    Dim iRow As Long
    For iRow = 2 To LastRow
        If ws.Cells(iRow, 1).Value <> vbNullString Then 'if a new store begins
            iStore = iStore + 1
            'Use following line to write the headers for the stores
            ws.Cells(1, 5 + iStore).Value = ws.Cells(iRow, 1).Value & " (Fruits)"
        End If
        ws.Cells(iRow, 5 + iStore).Value = ws.Cells(iRow, 4).Value
    Next iRow
End Sub

Count the stores in iStore and use that store count to determine the destination column.

Also note that you need to determine the LastRow in column D not A. Column D has more entries than A has. If you use A's last row it stops too early.

edited Jul 26 '18 at 12:17

answered Jul 26 '18 at 12:01

Pᴇʜ

56,719
10
49
73

Hi Peh, I have tested the code above, however, the fruits for each store is being stored not on the first row of the new column of the store. What if All fruits will be only on column F? It will just list all of the fruits for different stores in one column which is F. – Sevpoint Jul 26 '18 at 12:45
@Sevpoint I don't understand what you wanted to say. Can you add a screenshot of how the correct result would look like into your original question please? – Pᴇʜ Jul 26 '18 at 12:57
@Peh I have edited the picture and that will be the expected output on column F. – Sevpoint Jul 26 '18 at 13:43
I still don't get the point. Now column F is identical with column D. What is your question? – Pᴇʜ Jul 26 '18 at 13:51
Sorry to confuse. The main focus now is to put all the fruits from different stores in one column. It has the same goal but now the difference is the column where the fruits has to go. – Sevpoint Jul 26 '18 at 14:04
Yes, but there is no difference between column D and F now. So you can just copy D to F. Done. Please clarify where the issue is. – Pᴇʜ Jul 26 '18 at 14:06
Yes, I can copy the column D to column f, but what the important part for me is the store. So, it will copy the fruits under each store. – Sevpoint Jul 26 '18 at 14:11
They are already under each store. If the image is not the result that you want, please show a screenshot of how the result would look like **in the end**. – Pᴇʜ Jul 26 '18 at 14:13

Ian-Fogelman · Answer 2 · 2018-07-26T12:10:24.090

0

The following should do what you are requesting, I check column D for the last row instead of A since those are the values you are wanting to transpose:

Sub test()
    Dim i As Long, lastrow As Long
    lastrow = ActiveSheet.Cells(Worksheets(1).Rows.Count, "D").End(xlUp).Row
    For i = 2 To lastrow
        Cells(i, 1).Select
            If i < 6 Then
                Cells(i, 6) = Cells(i, 4).Value
            Else
                Cells(i, 7) = Cells(i, 4).Value
        End If
    Next i
End Sub

edited Jul 26 '18 at 12:10

answered Jul 26 '18 at 12:08

Ian-Fogelman

1,595
1
9
15

1

Note that this works only for 2 stores, but the OP said store count can increase. Additionally `If i < 6 Then` fails if the first store has more or less fruits than in the example. – Pᴇʜ Jul 26 '18 at 12:10

Nishanth Pinto · Answer 3 · 2018-07-26T12:38:31.387

First Try using below function to get Last Row, this is very handy.

Function LastRow(sh As Worksheet) As Integer
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlValues, _
       SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function

One more for Last column, just in case for your Future reference.

Function LastColumn(sh As Worksheet) As Integer
On Error Resume Next
LastColumn = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlValues, _
       SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
On Error GoTo 0
End Function

Now the Actual working procedure

Sub test()
Dim i as Long, InptClm as integer  'good to define the variable otherwise they will be considered as variant which is at higher memory rank.
Dim LastRow As Integer: LastRow = LastRow(activeworkbook.Sheets("Type sheet name here")

With activeworkbook.Sheets("Type Sheet Name here")
For i = 2 To lastrow
    ' you don't have to select here as selection slows the performance of codes.
    If .Cells(i, 1).Value <> "" Then
        ' Below code will make the column selection dynamic
        inptclm = .rows(1).find(What:=.cells(i,1)&" (Fruits)",After:=Cells(1,1),Lookat:=xlwhole).column()
    End If
        .Cells(i, inptclm) = Cells(i, 4).Value
Next I
end with
End sub

-- Code not tested, hope it will be able to assist you.

① Excel has more rows than `Integer` can handle. Always use `Long` instead, there is [no benefit in `Integer` at all](https://stackoverflow.com/a/26409520/3219613) in VBA. ② Using the same name twice (for a variable and a function: `LastRow = LastRow(activesheet)`) will drive you nuts soon or later (if this even is allowed). Always use unique names. — Pᴇʜ, Jul 26 '18 at 12:24
Agree on Interger Vs Long. Agree on using Sheet name but just wanted to keep it simple. Codes edited... — Nishanth Pinto, Jul 26 '18 at 12:28
What I meant to say was. You need to change *at least* **all row counting** variables into `Long` including the return type of your function … There are still `Integers`. • And you cannot name your variable `LastRow` **and** your function `LastRow` because this throws an error. Names must be unique. Test your code to see your errors. — Pᴇʜ, Jul 26 '18 at 12:39

score 0 · Answer 4 · answered Jul 26 '18 at 13:43

You could use SpecialCells to isolate each blank cells group in column A

Option Explicit

Public Sub test()

    Dim iArea As Long
    For Each area in Range("D2", Cells(Rows.Count, "D").End(xlUp)).Offset(,-3).SpecialCells(xlCellTypeBlanks).Areas
        With area.Offset(-1).Resize(.Rows.Count + 1)
            Range("F1").Offset(,iArea).Value = .Cells(1,1).Value
            Range("F2").Offset(,iArea).Resize(.Rows.Count).Value = .Value
        End With 
        iArea = iArea + 1
    Next
End Sub

Excel VBA: Loop through cells on another column basing on the first row

4 Answers4