VBA to add data automatically

[JayB0730]

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	abc	def	X
Transaction Code 2	ghi	jkl	X
Transaction Code 3	mno	pqr
Transaction Code 4	stu	vwx	X

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]

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]

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]

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

12/19/22​		Transaction Code 1
12/19/22​		Transaction Code 2
12/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]

It works like a charm, @breynolds0431 Thank you!