macro to copy / paste a series of date

[jkrenkel]

I am looking for a macro to do the following. In theory, this is what it should do

Sheet 1 - look in column b
If column b = Income then it would take Column C and Column D, copy it, go to sheet 2, paste it into the next empty row and then repeat it until all the data is looked at and copied correctly. A new report will be running daily so it almost acts like a statement of transactions.

I know there is a For loop in this thing, but when i do it, it pastes it into sheet 1, and then deletes it right away. This code is terrible, so any help will be appreciated. Thanks

Dim cell As Range

Dim cell1 As Range
Dim AssetNumber As Long

AssetNumber = Sheet1.Range("c2:c" & Sheet1.Range("c65536").End(xlUp).Row).Count

Sheet3.Select

' Loop for each row in selection.
For Each cell In Sheet3.Range("e3", Cells(65535, Sheet3.Range("e65536").End(xlToLeft).Column).End(xlUp))
    
cell.Offset(0, 1).Copy

For Each cell1 In Sheet1.Range("c2:c" & Sheet1.Range("c65536").End(xlToLeft).Column).End(xlUp)

Cells(AssetNumber + 1, 2).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
Next cell1
Next cell

 

[Andrew Poulsom]

Your code doesn't seem to do anything you describe:

1. There is no test for the word "Income".
2. You are copying from Sheet3 column E, not Sheet1 columns C:D.
3. You are pasting in Sheet1 not Sheet2.
4. I'm unclear why you have a loop within a loop.

See if this gets you closer to what you want:

Sub Test()
    Dim Sh1 As Worksheet
    Dim Rng1 As Range
    Dim Sh2 As Worksheet
    Dim Rng2 As Range
    Set Sh1 = Worksheets("Sheet1")
    Set Rng1 = Sh1.Range("B1:B" & Sh1.Range("B" & Sh1.Rows.Count).End(xlUp).Row)
    Set Sh2 = Worksheets("Sheet2")
    Set Rng2 = Sh2.Range("A" & Sh2.Range("A" & Sh2.Rows.Count).End(xlUp).Row).Offset(1, 0)
    Rng1.AutoFilter
    Rng1.AutoFilter Field:=1, Criteria1:="Income"
    Set Rng1 = Rng1.Offset(0, 1).Resize(, 2)
    Rng1.SpecialCells(xlCellTypeVisible).Copy
    Rng2.PasteSpecial xlValues
    Sh1.AutoFilterMode = False
    Application.CutCopyMode = False
End Sub

 

[jkrenkel]

Thanks, I will test this out. I was just toying around with some codes i used in the past, and had not gotten to the income part. One day i will actually get a book on this or take a class.

 

[jkrenkel]

Ok so it copies and pastes, but how do I get this to loop though source worksheet and paste into the data worksheet. There is probably going to be 50 entries of data a day. So I would like this to verify the data, copy it, paste it into the data worksheet, then go back to the source, find the next valid line and roll through it that way.

That is why I had my original loop in there.

 

[Andrew Poulsom]

My code uses AutoFilter to show only the rows with the text "Income" in column B. It then copies and pastes those records in one go.

So why do you need a loop?

 

[jkrenkel]

ahhhhh, silly me, silly me.

 

[jkrenkel]

Andrew,

Taking this a step further, if I autofilter a rng series from another worksheet, basically compare the data and get a match. I am freezing my macro when the value from sheet 1 is not pulling any matches from sheet 2. I need it to get back into the loop if it cannot find it. Here is my code

Sub do_it()

 
 Dim i As Integer
 Dim j As Integer
 
 Dim Sh1 As Worksheet
  Dim rng1 As Range
  
  Dim Sh2 As Worksheet
  Dim rng2 As Range
  
i = 2



Set Sh1 = Sheet2 ' BNY Acct List
Set rng1 = Sh1.Range("a1:a" & Sh1.Range("A" & Sh1.Rows.Count).End(xlUp).Row)

Set Sh2 = Sheet1
Set rng2 = Sh2.Cells(i, 1) ' JPM Acct List - Paste Data here

rng2.Select

 
 
 
Do

If IsEmpty(rng2) Then Exit Do

'Sh1.Activate
rng1.AutoFilter
    rng1.AutoFilter Field:=1, Criteria1:=rng2.Value
    

    Set rng1 = rng1.Offset(1, 1).Resize(, 2)
    
   rng1.SpecialCells(xlCellTypeVisible).Copy
  
   
   
   'Sh2.Activate
   Set rng2 = rng2.Offset(, 1).Resize(, 2)
   rng2.Select
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    Sh1.AutoFilterMode = False
    Application.CutCopyMode = False
    
 i = i + 1
 Set rng2 = Cells(i, 1)
 Set rng1 = Sh1.Range("a1:a" & Sh1.Range("A" & Sh1.Rows.Count).End(xlUp).Row)
 
  Loop
 
 
    
End Sub

 

[Andrew Poulsom]

Soory, what does "I am freezing my macro when the value from sheet 1 is not pulling any matches from sheet 2" mean?

 

[jkrenkel]

It crashes excel, gives me a not repsonding message and I have to manually exit excel.

So when it loops through the macro, it works great. Then it hits a number that has no matches, and just sits there until I close excel.

 

[Andrew Poulsom]

I don't know why that should happen, but I would expect an error if no visible cells were found. Try the untested:

Sub do_it() 
   Dim i As Integer 
   Dim j As Integer 
   Dim Sh1 As Worksheet 
   Dim rng1 As Range 
   Dim Sh2 As Worksheet 
   Dim rng2 As Range 
   i = 2 
   Set Sh1 = Sheet2 ' BNY Acct List 
   Set rng1 = Sh1.Range("a1:a" & Sh1.Range("A" & Sh1.Rows.Count).End(xlUp).Row) 
   Set Sh2 = Sheet1 
   Set rng2 = Sh2.Cells(i, 1) ' JPM Acct List - Paste Data here 
   rng2.Select 
   Do 
      If IsEmpty(rng2) Then Exit Do 
'      Sh1.Activate 
      rng1.AutoFilter 
      rng1.AutoFilter Field:=1, Criteria1:=rng2.Value 
      Set rng1 = rng1.Offset(1, 1).Resize(, 2) 
      On Error Resume Next
      rng1.SpecialCells(xlCellTypeVisible).Copy 
      If Err = 0 Then
'         Sh2.Activate 
         Set rng2 = rng2.Offset(, 1).Resize(, 2) 
         rng2.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
         Sh1.AutoFilterMode = False 
         Application.CutCopyMode = False 
      Else
         Err.Clear
      End If    
      On Error GoTo 0
      i = i + 1 
      Set rng2 = Cells(i, 1) 
      Set rng1 = Sh1.Range("a1:a" & Sh1.Range("A" & Sh1.Rows.Count).End(xlUp).Row) 
   Loop 
End Sub