Loop Through Data & Copy To Another Worksheet

G

Gav_GM

New member
Joined
Jun 1, 2018
Messages
3
Reaction score
0
Points
0
Excel Version(s)
2016
Hi,


I am new to the forum and would appreciate your help with the following please. I am a novice VBA user and am having difficulty with the following code.


Basically I am trying to categorise expenses. I have 2 worksheets in a single workbook, the 1st ("CSVData") contains a list of all expense items,
the 2nd ("Data") contains the categories for the expenses to be posted against. In the example, I have only listed 2 of the categories.


The code attempts to search "CSVData" for any expense items against the 2 categories listed in "Data", and post the corresponding cost amounts under the 2 categories:
"RITCHIES" and "Telstra DDebit".


The code currently successfully searches the data in "CSVData" and pastes the relevant amounts into "Data", but it fails after the 1st successfull run.


It returns an error "Run-time error '9': Sbscript out of range"


Any assistance would be much appreciated. I have attached my working file.




Code:

Code: 
Sub CallFunction()


Call fncCategoriseCosts




End Sub

Code: 
Public Function fncCategoriseCosts()


    Sheets("CSVData").Select
    
    Dim Cat(1 To 2) As String
                
    Cat(1) = "RITCHIES"
    Cat(2) = "Telstra DDebit"
    
      
    Sheets("Data").Select
    
    Dim Cat2(1 To 2) As String
                
    Cat2(1) = ActiveSheet.Cells.Find("RITCHIES") 'Array("RITCHIES")
    Cat2(2) = ActiveSheet.Cells.Find("Telstra DDebit") 'Array("Telstra DDebit")
    
    
        
    Application.ScreenUpdating = False
    
    Dim xlCalc As XlCalculation






    xlCalc = Application.Calculation


          
    
    'SET DATA RANGES
    '________________
    
    
    'CSVData" Tab
    
     Sheets("CSVData").Select
    
        Dim myRange1 As Range
        Set myRange1 = Range("C2:C600")
        
    Worksheets("Data").Select
    
        Dim myRange2 As Range
        Set myRange2 = Range("A1:B1")
         
   
    '______________________________________________________________________________________________________________
        
    'CATEGORISE EXPENDITURE
    
    
    For Test = 1 To 30
    
    Dim rCell As Range
    
    
    'COPY DATA
    
    Sheets("CSVData").Select
    
    '_____________________________________________________________________________________________________
    
               
    For Each rCell In myRange1
                  
        Do While rCell.Value Like "*" & Cat(Test) & "*"
            If rCell.Value Like "*" & Cat(Test) & "*" Then
                rCell.Activate
                ActiveCell.Offset(0, -1).Select
                Selection.Copy
            
                Exit For
        
            End If
        
        Loop 
                
    Next rCell






    'PASTE DATA
    
    
    Sheets("DATA").Select
    
        For Each rCell In myRange2
            Do While rCell.Value = Cat2(Test)
                If rCell.Value = Cat2(Test) Then
                    rCell.Activate
                        If IsEmpty(rCell) = False Then
                            ActiveCell.Offset(1).Select
                            Selection.PasteSpecial Paste:=xlPasteValues
                        End If
                    Exit For
                End If
                
            Loop 
                
        Next rCell
                
            
    Next Test


        
    
    Application.CutCopyMode = False


End Function
 

Attachments

  • Sample Expenses Categorisation.xlsm
    22.8 KB · Views: 17
Last edited by a moderator:
Hi and welcome
in the future, could you please wrap your code with code tags? ( click "Go advanced - Select code - click the #button) I did it for you this time.
Thank you
 
Thanks Pecoflyer, will do
 
Does this accomplish what you're after ?
Code: 
Sub Test_1()
    Dim MyRange As Range, rCell As Range
    Dim rng As Range, cel As Range
    Dim lc As Long, wr As Long

With Sheets("Data")
    lc = .Cells(1, Columns.Count).End(xlToLeft).Column
    Set MyRange = .Range(.Cells(1, 1), .Cells(1, lc))
End With

With Sheets("CSVData")
    lc = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Set rng = .Range("C2:C" & lc)
End With

For Each rCell In MyRange
    For Each cel In rng
        If InStr(1, UCase(cel.Value), UCase(rCell.Value)) > 0 Then
            wr = wr + 1
            rCell.Offset(wr).Value = cel.Offset(, -1).Value
        End If
    Next cel
    wr = 0
Next rCell

End Sub
 
That's great NoS, exactly what I was after. Thanks very much for taking the time to post a response, much appreciated.
 
You must log in or register to reply here.
Back
Top