Loops, selecting multiple cells, ranges using offset and resize, copying to new sheet

[Goldylocks]

Hi

As a newbie I've gone through a heap of posts, but I cant quite string the code together for this one.

Context: I have a series of budget templates worksheets that are generated from a list of project codes in column B on a sheet called "Tx project list MYPD 4" - can be up to 200 sheets. These will be filled in after which I need to collate the data and form one report to be uploaded into SAP.

1. First I need to clear old data in Reporting Sheet that I will be repopulating called "SAP upload file"
2. Then I need to loop through all of the new budget sheets and
3. Check to see if there is any data on the project sheet (by simply checking a single cell with a total in it - "DB64")
4. If the value is zero, I move on to the next sheet
5. If the value is > 0 Then
6. Check through 2 ranges "CT11:CZ40" & " CT43:CZ62" to find which cells are > 0
7. For each cell in those ranges > 0 find (a) the corresponding Financial Year Code, which is in cell (r10, same column) & (b) Project Code, which is in cell (B4) of each sheet & (c) GL Code which is in "same row, column E" & (d) range of 12 cells which will be offset from active cell (same row, 86 columns to left)
8. For each cell > 0 I need to copy these four (a) & (b) & (c) & (d) and paste them into a different sheet "SAP upload file" in the last available row with (a) in column "A" & (b) in column B and (c) in column C and (d) in column E

I can generate the templates.

It looks like I need a routine to loop through the budget sheets and check the first variable i.e. IF DB65 > 0 which will then call a subroutine to do the work if the value is > 0.

I've been using something like this:

Dim lastrow As Long
Dim sapsheet As Worksheet
Dim strWsName As String
Dim listsheet As Worksheet
Dim rngCell As range


Set sapsheet = ThisWorkbook.Sheets("SAP upload file")
Set listsheet = ThisWorkbook.Sheets("Tx project list MYPD 4")


'1st clean out old data



sapsheet.range("a1110000").ClearContents


'the project list loop


Dim strSheetActive As String: strSheetActive = ActiveSheet.Name
Application.ScreenUpdating = False

With listsheet
For Each rngCell In .range("b2:b" & .range("b" & .Rows.Count).End(xlUp).Row)
If Trim(rngCell.Value) <> vbNullString And ActiveSheet.range("DB64").Value > 0 Then Call MacroToCollateData(rngCell.Value)
Next rngCell
End With

Application.Goto sapsheet.Cells(1)
Application.ScreenUpdating = True
Set rngCell = Nothing

End Sub

The loop seems to be working OK, but I cant build the subroutine "MacroToCollateData" to do the stuff I describe in steps 3 - 8

Please can someone help me out.

Many Thanks

 

[farmerscott]

Goldylocks,

Welcome to MrExcel.

If you want this done urgently and efficiently then I will leave this to an expert; otherwise I am happy to attempt your problem.

So to get started.... in your point 2 above... when you say "the new budget sheets", are these sheets that have been filled in (as suggested by your code) or are they new ones generated from your list in sheet "Tx project list MYPD 4"?

FarmerScott

 

[Goldylocks]

Hi farmerscott

There is some time pressure but, I appreciate the help...

The sheets are generated from a Template called "Template" using a list in column B on listsheet. They are then filled in by the relevant project manager. When I get them back I need to loop through and collate the data as described in the steps above. As there are lots of sheets, I thought I would check the sheet to see if there was any data by checking a single cell and then either running a subroutine to collate or moving on.

I'd appreciate any help you can give.

Thanks
Goldylocks

 

[farmerscott]

Goldylocks,

So i can see if I am on the right track, try this code on a copy of your work. It does up to and including your step 6. The numbers that are greater than 0 are highlighted in green and blue.

Sub LoopSheets()
    
Dim ws As Worksheet
Dim wsname As Worksheet
Dim sapsheet As Worksheet
Dim listsheet As Worksheet
Dim x As Integer
Dim y As Integer

    
Set sapsheet = Sheets("SAP upload file")
Set listsheet = Sheets("Tx project list MYPD 4")

Application.ScreenUpdating = False
    
sapsheet.Range("a11:p10000").ClearContents 'clean out old data
    
    
    For Each ws In Worksheets
        
        If ws.Name <> "SAP upload file" And ws.Name <> "Tx project list MYPD 4" Then
           
           If Sheets(ws.Name).Range("DB64").value > 0 Then
                For x = 11 To 40
                    For y = 98 To 104
                     If Cells(x, y).value > 0 Then
                    Cells(x, y).Interior.Color = vbGreen
                    End If
                    Next y
                  Next x
                  
                  For x = 43 To 62
                    For y = 98 To 104
                     If Cells(x, y).value > 0 Then
                    Cells(x, y).Interior.Color = vbBlue
                    End If
                    Next y
                  Next x
                End If
           End If
       
    Next ws
    Application.ScreenUpdating = True
End Sub

FarmerScott

 

[farmerscott]

Goldylocks,

try on a copy of your data-

Sub LoopSheets()
    
Dim ws As Worksheet
Dim sapsheet As Worksheet
Dim listsheet As Worksheet
Dim x As Integer
Dim y As Integer
Dim lr As Long
Set sapsheet = Sheets("SAP upload file")
Set listsheet = Sheets("Tx project list MYPD 4")

Application.ScreenUpdating = True
    
sapsheet.Range("a11:p10000").ClearContents 'clean out old data
    
    
    For Each ws In Worksheets
        
        If ws.Name <> "SAP upload file" And ws.Name <> "Tx project list MYPD 4" Then
           
           If ws.Range("DB64").Value > 0 Then
            Sheets(ws.Name).Activate
                For x = 11 To 40
                    For y = 98 To 104
                     If Cells(x, y).Value > 0 And Cells(x, y).Text = True Then
                    lr = Worksheets("SAP upload file").Cells(Rows.Count, "A").End(xlUp).Row
                    Cells(10, y).Copy Destination:=Worksheets("SAP upload file").Range("A" & lr + 1)
                    Cells(4, 2).Copy Destination:=Worksheets("SAP upload file").Range("B" & lr + 1)
                    Cells(x, 5).Copy Destination:=Worksheets("SAP upload file").Range("C" & lr + 1)
                    Cells(x, y-86).Copy Destination:=Worksheets("SAP upload file").Range("E" & lr + 1)
                    End If
                    Next y
                  Next x
                 
                  For x = 43 To 62
                    For y = 98 To 104
                     If Cells(x, y).Value > 0 And Cells(x, y).Text = True Then
                    lr = Worksheets("SAP upload file").Cells(Rows.Count, "A").End(xlUp).Row
                    Cells(10, y).Copy Destination:=Worksheets("SAP upload file").Range("A" & lr + 1)
                    Cells(4, 2).Copy Destination:=Worksheets("SAP upload file").Range("B" & lr + 1)
                    Cells(x, 5).Copy Destination:=Worksheets("SAP upload file").Range("C" & lr + 1)
                    Cells(x, y-86).Copy Destination:=Worksheets("SAP upload file").Range("E" & lr + 1)
                    
                    End If
                    Next y
                  Next x
                
                End If
           End If
       
    Next ws
    
    Application.ScreenUpdating = True
End Sub

Can you clarify the last piece of data you want transfered over "(d) range of 12 cells which will be offset from active cell (same row, 86 columns to left)"? I have had a stab at it in the code.

FarmerScott

 

[Goldylocks]

Hi FarmerScott

I think you are definitely on the right track! - I cant thanks you enough for taking the time to help me out. On re-reading my post, I realised that I never explained the request very well. In the interim I have also received some invaluable help from another member JackDanIce. I have posted his solution below:

Sub to replicate budget sheets

Sub CreateBudgetSheets()


Dim i As Long
Dim ws As Worksheet: Set ws = Sheets("Template")
Dim sh As Worksheet: Set sh = Sheets("Tx project list MYPD 4")


Application.ScreenUpdating = False

With sh
For i = 2 To .range("B" & Rows.Count).End(xlUp).Row
If LenB(.range("B" & i).Value) = 0 Then Exit For
ws.Copy After:=ws
With ActiveSheet
.Name = sh.range("B" & i).Value
.DrawingObjects.Delete
End With
Next i
ws.Select
End With


Application.ScreenUpdating = True


End Sub

Sub to collate the budget sheets once they have been manually filled in by minions

Sub CollateResults()


Dim wList As Worksheet: Set wList = Sheets("Tx project list MYPD 4")
Dim wSAPUpload As Worksheet: Set wSAPUpload = Sheets("SAP Upload File")
Dim wExists As Worksheet
Dim rng1 As range, rng2 As range, check_rng As range
Dim x As Long, y As Long


Application.ScreenUpdating = False


wSAPUpload.range("A11:P10000").ClearContents


With wList
x = .range("B" & .Rows.Count).End(xlUp).Row
For Each rng1 In .range("B2:B" & x)
On Error Resume Next
Set wExists = Sheets(rng1.Value)
On Error GoTo 0
If Not wExists Is Nothing Then
With Sheets(rng1.Value)
On Error Resume Next
.Cells.Ungroup
On Error GoTo 0
If LenB(.range("DB64").Value) > 0 Then
.Select
Set check_rng = .range("CT11:CZ40")
For Each rng2 In check_rng
If rng2.Value <> 0 Then
With wSAPUpload
y = Application.WorksheetFunction.Max(11, .range("A" & .Rows.Count).End(xlUp).Row + 1)
.range("A" & y).Value = Sheets(rng1.Value).Cells(10, rng2.Column).Value
.range("B" & y).Value = Sheets(rng1.Value).range("B4").Value
.range("C" & y).Value = Sheets(rng1.Value).range("E" & rng2.Row).Value
.range("E" & y).Resize(, 12).Value = Sheets(rng1.Value).range("K" & rng2.Row).End(xlToRight).Resize(, 12).Value
End With
End If
Next rng2
Set check_rng = .range("CT43:CZ62")
For Each rng2 In check_rng
If rng2.Value <> 0 Then
With wSAPUpload
y = Application.WorksheetFunction.Max(11, .range("A" & .Rows.Count).End(xlUp).Row + 1)
.range("A" & y).Value = Sheets(rng1.Value).Cells(10, rng2.Column).Value
.range("B" & y).Value = Sheets(rng1.Value).range("B4").Value
.range("C" & y).Value = Sheets(rng1.Value).range("E" & rng2.Row).Value
.range("E" & y).Resize(, 12).Value = rng2.End(xlToLeft).End(xlToLeft).Resize(, 12).Value
End With
End If
Next rng2
End If
End With
End If
Set wExists = Nothing
Next rng1
End With


Application.ScreenUpdating = True


End Sub

 

[farmerscott]

Goldylocks,

thanks for the positive feedback.

I have adjusted the code to take in your item (d) based on JackDanIce's solution.

Sub LoopSheets()
    
Dim ws As Worksheet
Dim sapsheet As Worksheet
Dim listsheet As Worksheet
Dim x As Integer
Dim y As Integer
Dim lr As Long
Set sapsheet = Sheets("SAP upload file")
Set listsheet = Sheets("Tx project list MYPD 4")

Application.ScreenUpdating = True
    
sapsheet.Range("a11:p10000").ClearContents 'clean out old data
    
    
    For Each ws In Worksheets
        
        If ws.Name <> "SAP upload file" And ws.Name <> "Tx project list MYPD 4" Then
           
           If ws.Range("DB64").Value > 0 Then
            Sheets(ws.Name).Activate
                For x = 11 To 40
                    For y = 98 To 104
                     If Cells(x, y).Value > 0 And Cells(x, y).Text = True Then
                    lr = Worksheets("SAP upload file").Cells(Rows.Count, "A").End(xlUp).Row
                    Cells(10, y).Copy Destination:=Worksheets("SAP upload file").Range("A" & lr + 1)
                    Cells(4, 2).Copy Destination:=Worksheets("SAP upload file").Range("B" & lr + 1)
                    Cells(x, 5).Copy Destination:=Worksheets("SAP upload file").Range("C" & lr + 1)
                    Cells(x, y).Offfset(0, -86).Resize(, 12).Copy Destination:=Worksheets("SAP upload file").Range("E" & lr + 1).Resize(, 12)
                    End If
                    Next y
                  Next x
                 
                  For x = 43 To 62
                    For y = 98 To 104
                     If Cells(x, y).Value > 0 And Cells(x, y).Text = True Then
                    lr = Worksheets("SAP upload file").Cells(Rows.Count, "A").End(xlUp).Row
                    Cells(10, y).Copy Destination:=Worksheets("SAP upload file").Range("A" & lr + 1)
                    Cells(4, 2).Copy Destination:=Worksheets("SAP upload file").Range("B" & lr + 1)
                    Cells(x, 5).Copy Destination:=Worksheets("SAP upload file").Range("C" & lr + 1)
                    Cells(x, y).Offfset(0, -86).Resize(, 12).Copy Destination:=Worksheets("SAP upload file").Range("E" & lr + 1).Resize(, 12)
                    
                    End If
                    Next y
                  Next x
                
                End If
           End If
      
    Next ws
    
    Application.ScreenUpdating = True
End Sub

Do you now have both or one code working for you?

cheers,

FarmerScott