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

 

[nemmi69]

Do you have a column title with Jan, Feb etc?

 

[Kamolga]

Hi,

[LEFT][COLOR=#333333][FONT=monospace]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 [/FONT][/COLOR][COLOR=#008000]Monthly[/COLOR][COLOR=#333333][FONT=monospace]data[/FONT][/COLOR]

Windows("Spreadsheet.xlsx").Activate

[COLOR=#008000]Dim Ws as Worksheet[/COLOR]
[COLOR=#008000]For each Ws in ActiveWorkbook.Worksheets[/COLOR]

[COLOR=#008000]If (Ws.name=sheets("Jan").name or Ws.name=sheets("Feb").name or Ws.name=sheets("Mar").name or Ws.name=sheets("Apr").name or Ws.name=sheets("Mai").name or Ws.name=sheets("Jun").name _
[LEFT][LEFT][LEFT][LEFT][LEFT]or Ws.name=sheets("Jul").name or Ws.name=sheets("Aug").name or Ws.name=sheets("Sep").name or [COLOR=#008000][FONT=Verdana]Ws.name=sheets("Oct").name or [/FONT][/COLOR]Ws.name=sheets("Nov").name or Ws.name=sheets("Dec").name) then[/LEFT]
[/LEFT]
[/LEFT]
[/LEFT]
[/LEFT]
[/COLOR]
[COLOR=#008000]WS[/COLOR].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.[COLOR=#008000]value = ws.name & " [/COLOR][COLOR=#008000]2018"[/COLOR][COLOR=#b08500]
[/COLOR][/LEFT]
[COLOR=#008000][LEFT]End if[/LEFT]
[/COLOR][COLOR=#ff0000][LEFT]
[/LEFT]
[/COLOR][LEFT][COLOR=#333333][FONT=monospace]
[/FONT][/COLOR][/LEFT]
[COLOR=#008000][LEFT]Next WS[/LEFT]
[/COLOR][LEFT][COLOR=#333333][FONT=monospace]

[LEFT][COLOR=#333333][FONT=monospace]'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[/FONT][/COLOR][/LEFT]
[B][I][U][SUB][SUP]<strike>
</strike>[/SUP][/SUB][/U][/I][/B][/FONT][/COLOR][/LEFT]

Note that I would normally not work with Sheet names as if you or a user decide to change it one day, you macro is useless. Instead I whould change in VBA the "Sheet1" of Sheet1("Jan") into ShJan. To do so, simply select sheet1 in left column and change the first line of properties below. The macro would then become

If (Ws=ShJan or Ws=ShFeb etc.) then

and changing names of the sheets would still be possible later on.

 

[nemmi69]

will this do?

Option Explicit


Sub CopyDatData()


Dim Months As Variant
Dim MonthsLng As Variant
Dim MonthLoop As Integer
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




'############ Get the month ###############
Months = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
MonthsLng = Array("January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")
'############ Loop


For MonthLoop = 1 To 12
    Windows("Spreadsheet.xlsx").Activate
    Sheets(Months(MonthLoop)).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 = MonthsLng(MonthLoop) & " 2018"


Next MonthLoop
'###### End Loop


'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

 

[nikio8]

each of these select and activate, you can delete and shorten your code.

but you could use

Dim sh as Excel.Worksheet
For each sh in Workbook("DataPull")
sh.Range("A1:C4").copy Destination:=Workbook1.Sheet1.cells(1, ---find last row---.W1.Sh1)
Next sh

 

[whazzzzzupp17]

All - Both codes work, but it still overwrites the previous tab data. The CountR rewrites over the data from the previous month tab. It needs to write the data on the next cell on spreadsheet one. Instead it keeps writing over the data.

The fix needs to come from the line countR. This formula gives me the row count, but I need to be able to record the previous countR value so I know where to paste the next data from the next tab.

For example. If jan has 50 rows of data copied and feb has 20 rows, feb would paste the data on row 51. Keep in mind the orignal paste on jan would be in C4 and another tab name paste in A4

 

[dmt32]

Hi,
untested but see if this update to your code does what you want

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
    
'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 - "
            CountR = .Cells.Find("Grand Total -", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            
'Define range rows and columns to copy.
            Set DataRange = .Range("A6:U" & CountR)
        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
'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

Dave

 

[whazzzzzupp17]

I'm getting an error with this one "Object variable or With Block variable not set"

Also, it looks like your spreadsheet just loops through the first 12 sheets rather than the specific month name tabs.

The other two formulas work, but they have the same issues I had when I created it. I need to paste it on the next cell after the previous copied data. "CountR"

 

[dmt32]

I'm getting an error with this one "Object variable or With Block variable not set"

Are any of the sheets you are copying from the source workbook blank?

Code Loops each Month Name tab using MonthName function

 

[whazzzzzupp17]

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.