Adjusting my VBA to work on multiple sheets

[whazzzzzupp17]

I created the code below that works perfectly, however, I have to copy it 12 times for it to work properly.

It copies data from another spreadsheet within tabs named for each month (Jan through Dec).

Can someone help me make this into a For loop so I don't have so much duplication and confusion? My script works perfect. I just need it to cycle through sheets Jan thorugh Dec.

The issue I had when I created a For loop, was I couldn't paste the values correctly within the next cell "CountR". I didn't know how to figure that out.

Option Explicit

Sub CopyDatData()


Dim Sheet As Worksheet
Dim CountR As Long
Dim sourceOne As Workbook
Dim DataRange As Range


'Disable updating to increase performance
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


'Define the workbook locations
Set sourceOne = Workbooks.Open("E:\Downloads\Spreadsheet2.xlsx", True, True)
sourceOne.Activate




'Copy Jan data


Windows("Spreadsheet.xlsx").Activate
Sheets("Jan").Select
Set Sheet = ActiveSheet
   


'Using the find function to locate the last row. Searching for "Grand Total - "


  CountR = Sheet.Cells.Find("Grand Total -", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
  
'Define range length and size.


  Set DataRange = Range("A6:U" & CountR)


'Select the range.
  DataRange.Select
  Selection.Copy
  
'Paste within Original spreadsheet within the DataPull tab
  Windows("Spreadsheet1.xlsm").Activate
  Sheets("DataPull").Select
  Range("C4").Select
  Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
  Range(Cells(4, 1), Cells(CountR - 2, 1)).Select
  Selection.FormulaR1C1 = "January 2018"


'Close the source file
Application.CutCopyMode = False
sourceOne.Close False 'False does not save the source file.
Set sourceOne = Nothing


'Re-enable updating
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic




End Sub

 

[dmt32]

try this update

Option Explicit


Sub CopyDatData()
    Dim FileName As String
    Dim CountR As Long, lr As Long
    Dim i As Integer
    Dim wbSourceOne As Workbook
    Dim wsDataPull As Worksheet
    Dim DataRange As Range, FindGrandTotal As Range
    
'manage errors
    On Error GoTo myerror
    
'specify Full filename
    FileName = "E:\Downloads\Spreadsheet2.xlsx"
    
'set object variable reference DataPull worksheet
    Set wsDataPull = ThisWorkbook.Worksheets("DataPull")
    
'Disable updating & calculation to increase performance
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual
    End With
    
'open source workbook read only
    Set wbSourceOne = Workbooks.Open(FileName, True, True)
    
'loop each Month Name Sheet (Jan, Feb, Mar etc) from source workbook
    For i = 1 To 12
'use MonthName function to get Sheet Name
'Set Abrreviate Argument False if Sheet Name is long Month Name (January, February etc)
        With wbSourceOne.Worksheets(MonthName(i, True))
            
'Using the find function to locate the last row. Searching for "Grand Total - "
            Set FindGrandTotal = .Cells.Find("Grand Total -", searchorder:=xlByRows, searchdirection:=xlPrevious)
    
           If Not FindGrandTotal Is Nothing Then
            CountR = FindGrandTotal.Row
'Define range rows and columns to copy.
                Set DataRange = .Range("A6:U" & CountR)
            Else
'month sheet empty or search value missing
                GoTo NextSheet
           End If
        End With
        
'copy the range.
        DataRange.Copy
        
'Paste within Original spreadsheet within the DataPull tab
        With wsDataPull
'get last used row in Col C
        lr = .Cells(.Rows.Count, "C").End(xlUp).Row
'increment to next blank row
        lr = IIf(lr <= 4, 4, lr + 1)
'paste data
            .Cells(lr, 3).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
                                       Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                                       
            .Cells(lr, 1).Resize(CountR - 2, 1).Value = MonthName(i, False) & " " & Year(Date)
            
        End With
        
NextSheet:
'clear range object variable
        Set DataRange = Nothing
'clear clipboard
        Application.CutCopyMode = False
    Next i
        
myerror:
'close source workbook
        If Not wbSourceOne Is Nothing Then wbSourceOne.Close False
'Re-enable updating
        With Application
            .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
        End With
'report errors
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

I suspect error is due to either empty month sheet in source workbook or search value cannot be found.

Updated code should manage this.

Dave

 

[dmt32]

Good call.

I figured out the issue with your help, but ran into another question. The fix was in regards to searching for the last row. I must have accidentally deleted Grand Total on my last line in the Sep tab.

Regarding my last question: Some of my tabs are not abbreviated properly on the source spreadsheet. For example. Sep is actually written as Sept, same with July, etc.

How can I rework this to account for it? I'm unable to change tab names as the spreadsheet is read only by other users.

Glad you figured it but use updated code & will manage error.

MonthName function produces either Full Month Name or abbreviated in normal form Jan Feb etc. If your tab Month names do not follow conventional formats then couple of options maybe

1 - if sheets are always in same position in workbook then you can use the sheets index property

2 - You can hard code an Array as in #Post 4 with correct names

Dave