# VBA to add data automatically



## JayB0730 (Dec 19, 2022)

Hello,
I have a workbook with two sheets.

*Sheet 1:*

*Date**Void Indicator**Transaction Code*_Current Date__Check Box (will be skipped for this example)__Transaction Code 1__Current Date__Check Box (will be skipped for this example)__Transaction Code 2_

*Sheet 2 "Table1":*

*Transaction Code**Data 1**Data 2**Flag*_Transaction Code 1_abcdefX_Transaction Code 2_ghijklX_Transaction Code 3_mnopqr_Transaction Code 4_stuvwxX

*What I want to accomplish*:
I want to create a macro that goes to Sheet 2, Table 1 and looks for all transaction codes with the flag "x," and goes to Sheet 1, looks for the last open cell in column Date Column and enters the current date and transaction code in the Transaction Code field. This process needs to continue and enter a new row with both data points until all Transaction flags with "X" is completed.

Thanks in advance for your help!
Jay


----------



## breynolds0431 (Dec 19, 2022)

Hi there. This should accomplish what you need. Try adding the below into a normal module.


```
Sub RecFlags()

'declare book and sheets
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dWS As Worksheet: Set dWS = wb.Sheets("Sheet1")
Dim sWS As Worksheet: Set sWS = wb.Sheets("Sheet2")

'create loop through sWS's Flag column (col. D)
Dim c As Range
For Each c In sWS.Range("D2:D" & sWS.Cells(sWS.Rows.Count, 1).End(xlUp).Row)
    If LCase(c.Value) = "x" Then
        'determine next open row in column A of dWS
        With dWS
            Dim lrow As Long: lrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            .Cells(lrow, 1).Value = Date
            .Cells(lrow, 3).Value = sWS.Cells(c.Row, 1).Value
        End With
    End If
Next c

End Sub
```


----------



## Micron (Dec 19, 2022)

Rats. Been struggling with this for quite some time so I'll post it anyway for future consideration.

```
Sub TransCodes()
'this code goes into sheet with X values
Dim Lrow As Long, i As Integer, y As Integer
Dim rng As Range, cel As Range
Dim ary() As String

Lrow = Cells(Rows.count, "D").End(xlUp).Row
Set rng = Range("A2:A" & Lrow)

For Each cel In rng
     If UCase(Range("D" & rng.Row)) = "X" Then
          ReDim Preserve ary(y)
          ary(y) = cel.Value
          y = y + 1
     End If
Next

With Sheets("004") '<< change to destination sheet name
    .Activate
    Lrow = .Cells(Rows.count, "A").End(xlUp).Row
    For i = 0 To UBound(ary)
        .Cells(Lrow + 1, 1) = Date
        .Cells(Lrow + 1, 3) = ary(i)
        Lrow = Lrow + 1
    Next
End With

End Sub
```
EDIT - Hmm, does my array have a potential speed advantage since I'm not looping over the cells between the sheets to post the values? I'm new to Excel vba so not sure.


----------



## Micron (Dec 19, 2022)

I just tested the first code 2x but haven't yet figured out why it misses Transaction 3

12/19/22​Transaction Code 112/19/22​Transaction Code 212/19/22​Transaction Code 4
EDIT - I think the issue is on my end. Row doesn't move.
In my case, I should have this If UCase(Range("D" & *cel*.Row)) = "X" Then


----------



## JayB0730 (Dec 25, 2022)

It works like a charm, @breynolds0431 Thank you!


----------

