Need to fix macro to list data underneath each other

J

jeannie v

Hi :
I want this macro to give me the data in Columns B & C of a particular
person in Column A on "Transactions" Worksheet and enter in it Q4 and R4 on
the Named Worksheet. What happens is that it doesn't list all of the
transactions for that person one underneath the other in Q4 and R4....it
enters the first transaction in Q4 & R4 but the just enters the last
transaction in Q44 & R44...with no transactions in between or underneath each
other.

Can someone help with this problem:

Sub Transactions()
'
' Transactions Macro
' Macro recorded 6/23/2007 by Jeannie Vincovich
'
' Keyboard Shortcut: Ctrl+n
'
Dim n As Integer, i As Integer
Dim rng As Range



Sheets("Transactions").Activate
n = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To n
Sheets("Transactions").Activate
If Cells(i, "A").Value = "Jane Doe" Then
Range("B" & i & ":C" & i).Copy
Sheets("Jane D").Activate
If Range("Q4") = "" Then
Set rng = Worksheets("Jane D").Range("Q4")
rng.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Else
Sheets("Jane D").Activate
n = Cells(Rows.Count, "A").End(xlUp).Row + 1
Set rng = Worksheets("Jane D").Range("Q" & n)
rng.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

End If
End If
Next i


End Sub
 
R

Roger Govier

Hi Jeannie

A couple of problems. You are using the same variable twice ("n") to
count the row numbers.
Also, when counting for Sheet Jane D, you are counting in column A, not
column Q.
Here is your code amended, so that it works. I have also shown a
shortened version below, which avoids all of the selecting, and runs
much quicker.

Sub Transactions()
'
' Transactions Macro
' Macro recorded 6/23/2007 by Jeannie Vincovich
'
' Keyboard Shortcut: Ctrl+n
'
Dim n As Integer, i As Integer, j As Integer
Dim rng As Range



Sheets("Transactions").Activate
n = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To n
Sheets("Transactions").Activate
If Cells(i, "A").Value = "Jane Doe" Then
Range("B" & i & ":C" & i).Copy
Sheets("Jane D").Activate
If Range("Q4") = "" Then
Set rng = Worksheets("Jane D").Range("Q4")
rng.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

Else
Sheets("Jane D").Activate
j = Cells(Rows.Count, "Q").End(xlUp).Row + 1
Set rng = Worksheets("Jane D").Range("Q" & j)
rng.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

End If
End If
Next i

End Sub


And here is the slightly more efficient code to do the same task.

Sub Transactions()
'
' Transactions Macro
' Macro recorded 6/23/2007 by Jeannie Vincovich
'
' Keyboard Shortcut: Ctrl+n
'
Dim n As Integer, i As Integer, j As Integer
Dim rng As Range, dest As Range
Dim wss As Worksheet, wsd As Worksheet
Set wss = Sheets("Transactions")
Set wsd = Sheets("Jane D")

n = wss.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To n
j = wsd.Cells(Rows.Count, "Q").End(xlUp).Row + 1
j = WorksheetFunction.Max(4, j)
Set dest = wsd.Range("Q" & j & ":R" & j)
If wss.Cells(i, "A").Value = "Jane Doe" Then
wss.Range("B" & i & ":C" & i).Copy dest
dest = dest.Value
End If
Next i

End Sub
 
M

Mike

Try this
Option Explicit
Sub testjanedoe()
Const nameTestCol = "A"
Const destCol = "Q"
Const transSheetName = "Transactions"
Const janeDSheetName = "Jane D"
Dim transWS As Worksheet
Dim janeDWS As Worksheet
Dim i As Long
Dim lastRow As Long
Dim janeLastRow As Long
Dim getName As String

getName = InputBox("Enter Name", "Get Name", "<Enter Name>")

Set transWS = Worksheets(transSheetName)
Set janeDWS = Worksheets(janeDSheetName)

lastRow = transWS.Cells(Rows.Count, nameTestCol).End(xlUp).Row
janeLastRow = janeDWS.Cells(Rows.Count, destCol).End(xlUp).Row + 1
For i = 1 To lastRow

If transWS.Range(nameTestCol & i).Value = getName Then

janeDWS.Range(destCol & i).Offset(4, 0).Value = _
transWS.Range(nameTestCol & i).Offset(0, 1).Value
janeDWS.Range(destCol & i).Offset(4, 1).Value = _
transWS.Range(nameTestCol & i).Offset(0, 2).Value
End If
Next i
End Sub
 
G

Greg Wilson

I see Roger beat me to it. An alternative to Roger's follows. Assumed is that
you don't actually want to hardcode the person's name ("Jane Doe") nor the
target worksheet name ("Jane D"). This lets you specify the name and confirm
the target worksheet name before making the transfer.

Sub Transactions2()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim c As Range
Dim i As Long, rw As Long
Dim nm As String, wsnm As String, addr As String
Dim msg As String, ttl As String

msg = "Step 1:" & vbCr & vbCr & "Enter name to search..."
ttl = "Transactions search"
nm = InputBox(msg, ttl)
If Len(nm) = 0 Then Exit Sub
i = InStr(nm, " ")
msg = "Step 2:" & vbCr & vbCr & "Confirm summary page name..."
wsnm = InputBox(msg, ttl, Left(nm, i + 1))
If Len(wsnm) = 0 Then Exit Sub
DoEvents
Set ws1 = Sheets("Transactions")

On Error Resume Next
Set ws2 = Sheets(wsnm)
If Err.Number <> 0 Then
msg = "Error: Summary page for " & wsnm & " does not exist "
MsgBox msg, vbCritical, ttl
Exit Sub
End If
On Error GoTo 0

rw = ws2.Cells(Rows.Count, "Q").End(xlUp).Row + 1
rw = IIf(rw < 4, 4, rw)
Set c = ws1.Columns(1).Find(nm, LookAt:=xlWhole)
If Not c Is Nothing Then
addr = c.Address
ws2.Cells(rw, "Q").Resize(1, 2).Value = c(1, 17).Resize(1, 2).Value
Else
msg = "Name not found in transactions list "
MsgBox msg, vbExclamation, ttl
Exit Sub
End If
i = 1
Do
Set c = ws1.Columns(1).FindNext(c)
If c.Address <> addr Then _
ws2.Cells(rw + i, "Q").Resize(1, 2).Value = c(1, 17).Resize(1, 2).Value
i = i + 1
Loop While c.Address <> addr
Set ws1 = Nothing: Set ws2 = Nothing: Set c = Nothing
End Sub
 
D

Don Guillett

Better than a loop is to filter and copy once. 1st one is recorded and the
second one is better.
If you don't need to convert to values
myrng.Copy
Sheets("sheet12").Range("r4"). _
PasteSpecial Paste:=xlPasteValues

could be reduced to ONE line
myrng.Copy Sheets("sheet12").Range("r4")



Sub Macro4()
'
' Macro4 Macro
' Macro recorded 6/23/2007 by Donald B. Guillett
'

'
Range("A1:C10").Select
Selection.AutoFilter
Selection.AutoFilter field:=1, Criteria1:="b"
Range("A1:C9").Select
Selection.Copy
Sheets("Sheet12").Select
Range("R4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
End Sub

Sub copypersonB()
With Sheets("sheet13")
Set myrng = .Range("a1:c" & _
..Cells(Rows.Count, "a").End(xlUp).row)
myrng.AutoFilter field:=1, Criteria1:="b"
myrng.Copy
Sheets("sheet12").Range("r4"). _
PasteSpecial Paste:=xlPasteValues
..ShowAllData
End With
End Sub
 
G

Greg Wilson

Sorry. I misread the post. Should be:

Sub Transactions2()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim c As Range
Dim i As Long, rw As Long
Dim nm As String, wsnm As String, addr As String
Dim msg As String, ttl As String

msg = "Step 1:" & vbCr & vbCr & "Enter name to search..."
ttl = "Transactions search"
nm = InputBox(msg, ttl)
If Len(nm) = 0 Then Exit Sub
i = InStr(nm, " ")
msg = "Step 2:" & vbCr & vbCr & "Confirm summary page name..."
wsnm = InputBox(msg, ttl, Left(nm, i + 1))
If Len(wsnm) = 0 Then Exit Sub
DoEvents
Set ws1 = Sheets("Transactions")

On Error Resume Next
Set ws2 = Sheets(wsnm)
If Err.Number <> 0 Then
msg = "Error: Summary page for " & wsnm & " does not exist "
MsgBox msg, vbCritical, ttl
Exit Sub
End If
On Error GoTo 0

rw = ws2.Cells(Rows.Count, "Q").End(xlUp).Row + 1
rw = IIf(rw < 4, 4, rw)
Set c = ws1.Columns(1).Find(nm, LookAt:=xlWhole)
If Not c Is Nothing Then
addr = c.Address
ws2.Cells(rw, "Q").Resize(1, 2).Value = c(1, 2).Resize(1, 2).Value
Else
msg = "Name not found in transactions list "
MsgBox msg, vbExclamation, ttl
Exit Sub
End If
i = 1
Do
Set c = ws1.Columns(1).FindNext(c)
If c.Address <> addr Then _
ws2.Cells(rw + i, "Q").Resize(1, 2).Value = c(1, 2).Resize(1, 2).Value
i = i + 1
Loop While c.Address <> addr
Set ws1 = Nothing: Set ws2 = Nothing: Set c = Nothing
End Sub
 
J

jeannie v

Hi Roger:

Thank you so much! It works beautifully EXCEPT it addes the first record
back to to the end of the list of transactions in Q & R-- .......other than
that this is excatly what I was looking for.

Could you help me get rid of that last entry which duplicates the first entry?
jeannie v
 
J

jeannie v

Hi Roger: I'm sorry.....my bad.......Ihad the transaction in twice....It
works beautifully........I can't thank you enough for lending your talents
and expertise.

I have another project that it basically the same thing....except instead of
the data in B&C on Transactions, it is A through L AND on the person's sheet
I want that data to appear in A4 through L17...Is there a way to modify this
macro to do that for my LoginLogout Sheet?
 
R

Roger Govier

Hi Jeannie

You're very welcome.

For your subsequent request, try the following.
I'm not sure whether you are saying the same sheet names or not.
Anyway, wss is the Source sheet and wsd is the Destination sheet, so
just change the sheet names in the Set statements as appropriate.

Sub Transactions2()
'
' Transactions Macro
' Macro recorded 6/23/2007 by Jeannie Vincovich
'
' Keyboard Shortcut: Ctrl+n
'
Dim n As Integer, i As Integer, j As Integer
Dim rng As Range, dest As Range
Dim wss As Worksheet, wsd As Worksheet
Set wss = Sheets("Transactions")
Set wsd = Sheets("Jane D")

n = wss.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To n
j = wsd.Cells(Rows.Count, "Q").End(xlUp).Row + 1
j = WorksheetFunction.Max(4, j)
Set dest = wsd.Range("A" & j & ":L" & j)
If wss.Cells(i, "A").Value = "Jane Doe" Then
wss.Range("A" & i & ":L" & i).Copy dest
dest = dest.Value
End If
Next i

End Sub
 
M

Mike

Option Explicit
Sub testjanedoe()
Const nameTestCol = "A"
Const destCol = "Q"
Const transSheetName = "Transactions"
Const janeDSheetName = "Jane D"
Dim transWS As Worksheet
Dim janeDWS As Worksheet
Dim i As Long
Dim lastRow As Long
Dim janeLastRow
Dim getName As String

getName = UCase(InputBox("Enter Name", "Get Name", "<Enter Name>"))

Set transWS = Worksheets(transSheetName)
Set janeDWS = Worksheets(janeDSheetName)

lastRow = transWS.Cells(Rows.Count, nameTestCol).End(xlUp).Row

For i = 1 To lastRow

If UCase(transWS.Range(nameTestCol & i).Value) = getName Then
janeLastRow = FindLastRow(janeDWS, destCol) + 1

janeDWS.Range(destCol & janeLastRow).Value = _
transWS.Range(nameTestCol & i).Offset(0, 1).Value

janeDWS.Range(destCol & janeLastRow).Offset(0, -1).Value = _
transWS.Range(nameTestCol & i).Value

janeDWS.Range(destCol & janeLastRow).Offset(0, 1).Value = _
transWS.Range(nameTestCol & i).Offset(0, 2).Value
End If
Next i
End Sub
Private Function FindLastRow(whatSheet As Worksheet, whichCol As String) As
Long


If Val(Left(Application.Version, 2)) < 12 Then
'in pre-2007 Excel
FindLastRow = whatSheet.Range(whichCol & Rows.Count).End(xlUp).Row
Else
'in Excel 2007 or later
FindLastRow = whatSheet.Range(whichCol &
Rows.CountLarge).End(xlUp).Row
End If
If FindLastRow = 1 And IsEmpty(whatSheet.Range(whichCol & "1")) Then
FindLastRow = 3 ' no entries at all in the column on the sheet
End If

End Function
 
J

jeannie v

Hi Roger: I need further help on the first macro.....it works fine for 1
person, but when I copy it and add the macro for another individual, it
doesn't work.....I'm really new at this macro stuff, so be gentle......
 
J

jeannie v

Hi Roger: On the second macro shown below.....the last line pops in A4:L4,
but then all of the other lines of data pop in lines 43 through 46...Can you
help with this? If you want me to send the workbook, I will.
 
J

jeannie v

Hi Roger: Well.....I was able to fix the Transactions Macro and I can't
thank you enough for your help.....The last piece is the LoginLogout.....I am
so close with the macro you provided, I just need it to pop up in A4 to L17
rather than down in lines 43 down.......

I hope and pray you are able to help me with this.....it can't be that hard,
right?
 
J

jeannie v

Hi Roger:

Don't laugh.......how do I remove NO SPAM from your email address and to
what address do I send it? I have previously just sent to email addresses
of the Group Experts from Outlook......I'm really new at this Group Community
stuff, so bear with me.

Thank you,
 
R

Roger Govier

Hi Jeannie

(e-mail address removed)

In order to avoids the spammers, most of us disguise our email address.
If you remove NOSPAM from the above, it will work
 
R

Roger Govier

Hi Jeannie

File received, fixed and returned.
The macro was selecting row 43, because you had entries below you range
of A4:L17, and starting from the end of sheet and working up, it found
entries in A42, hence made A43 the first row. Calculating "j" for the
row number to start, has been changed to
j = WorksheetFunction.CountA(Range("A3:A17")) + 4

Rather than repeating the code with different names and different
worksheets, I added a new sheet called List, which holds in columns A
and B the names and Sheetnames for the people whose data you want to
collect. There is an outer loop, which works through each name and sheet
in turn.

Hopefully this resolves all of your outstanding issues.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

MACRO IS NOT WORKING AS IT SHOULD 3
Filename Problem In a Macro 4
Help merging two VBA codes 2
Macro Related to Paste Values 2
Macro Amendment. 4
Can't Prevent Recalculation 4
Having difficulty copying and pasting on VBA 3
Runtime 9 error Check. 2

Top