Automated Daily Production Report - Excel

C

chadgaspard

New Member
Joined
Nov 4, 2018
Messages
14
I am in need of a vba module that would allow me to do the following:

I currently have a workbook which is Titled "Aspen DPR 10-19". The "10-19" changes based off of current month-year. This Daily Production Report has a tab titled "Monthly Report" and also has a tab for each day of the month simply titled; "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16" "17", "18", "19", "20", "21", "22", "23", "24, "25", "26", "27", "28", "29", "30", "31", and the last tab is "1". "1" represents the 1st day of the upcoming month.

I need vba code for a Button named "Transfer to New Month", which I already have on worksheet "1", that would copy all tabs, open a new workbook, and paste all tabs into the new workbook, but add or take away tabs based off how many days are in that upcoming month. I also need it to rename the date in cell range C4:D4 to the second day of the upcoming month (e.g. 11/2/19).

I also need vba code for a button I already have on each sheet titled "Transfer Well Test" that would copy all data from the current active worksheet section (cell range A43 through N49) and paste this data into the exact spot on the rest of the numbered worksheets (not the sheet titled "Monthly Report"), but done so based off of the number of days (tabs) for the current month - and transfer that same data to next months report (all numbered tabs from Tab "2" to Tab "1".

Is this possible? If so this would save me hours of copy and pasting and minimize mistakes made by human error. Thanks in advance.
 
Sort by date Sort by votes
chadgaspard said:

In addition, when I click the "Transfer To New Month" button on the last sheet (1) I would like the well test data to transfer to all pages in the new workbook that was copied from the active workbook along with the macros. If the upcoming months have more days, or less days, I would like it to adjust accordingly. By adjust accordingly I mean paste the correct number of sheets for the upcoming month and paste the well test data into all of the numbered sheets that represent a day. I don't want it to paste into the Monthly Report Sheet though because it does not contain cells to capture well test data.
​
Click to expand...

"New_Monthly_Workbook" will now only run if "Transfer_Well_Test" is ran while on sheet "1"

Code: 
Sub Transfer_Well_Test()


'SAVE BEFORE USING THIS TO MAKE SURE IT DOES WHAT YOU WANT PROPERLY


Dim WS As Worksheet, Starting_Worksheet As Long, Original_Worksheet As Worksheet, Range_Data As Range


'Day_Number = Date - DateSerial(Year(Date), Month(Date), 1) + 1 'day number


Set Original_Worksheet = ActiveWorkbook.ActiveSheet


With Original_Worksheet
     
    If IsNumeric(.Name) Then
             
        If CLng(.Name) <= 31 Then
            Set Range_Data = .Range("A43:N43") 'store this range in a variable
        Else
            MsgBox "Invalid worksheet day"
        
            End 'exit all subs        End If
        End If
        
    Else
    
        MsgBox "Invalid starting sheet"
        
        End 'exit all subs
        
    End If
    
End With


If Original_Worksheet.Name <> "1" Then  'if not running the macro from sheet "1"
                                        'then apply range to all other valid sheets
    For Each WS In ActiveWorkbook.Worksheets 'loop through worksheets
    
        With WS
    
            If Not WS Is Original_Worksheet And IsNumeric(.Name) Then
    
                If (CLng(.Name) > CLng(Original_Worksheet.Name) Or CLng(.Name) = 1) And CLng(.Name) <= 31 Then .Range(Range_Data.Address) = Range_Data
    
            End If
    
        End With
    
    Next


Else 'IF on sheet "1" then create a new workbook and apply range from sheet 1 to all
     'other valid worksheets in the new workbok
    
    Call New_Monthly_Workbook(Range_Data)


End If


End Sub
Sub New_Monthly_Workbook(RRR As Range) 'This sub is run from worksheet "1"


Dim Target_Month_Days, Target_Month_Day_1 As Date, X As Long, WS1 As Worksheet, New_WB As Workbook, _
FileN As String, ERR_WS As Worksheet, New_WS As Worksheet, SHP As Shape
 
Target_Month_Day_1 = DateSerial(Year(Date), Month(Date) + 1, 1) 'first day of next month


'Target_Month_Day_1 = DateSerial(2019, 12, 1) 'first day of Target Month if needed


Target_Month_Days = DateSerial(Year(Target_Month_Day_1), Month(Target_Month_Day_1) + 1, 1) - Target_Month_Day_1
                    
'first day of (Target_Month_Day_1 + 1 MONTH) - Target_Month_Day_1 = number of days in Tareget Month


Application.EnableEvents = False


Set New_WB = Workbooks.Add 'create new workbook and store object in a variable


Set WS1 = New_WB.Worksheets(1) 'first worksheet of the newly created workbook


CopyModules ThisWorkbook, New_WB


On Error Resume Next


For X = 1 To Target_Month_Days 'loop 1 to the number of days found in the target month


    Set ERR_WS = ThisWorkbook.Worksheets(CStr(X)) 'this will generate an error if it doesn't exist
    
    If Err.Number = 0 Then 'if the worksheet exists then copy it to the new Workbook
        
        If X = 1 Then
            ERR_WS.Copy After:=WS1
            Set New_WS = New_WB.Workbooks(WS1.Index + 1)
        Else
            ERR_WS.Copy Before:=WS1
            Set New_WS = New_WB.Workbooks(WS1.Index - 1)
        End If
        
        For Each SHP In New_WS.Shapes 'change macro reference of shapes to reference the newly created workbook
            SHP.OnAction = Replace(SHP.OnAction, ThisWorkbook.Name, New_WB.Name)
        Next SHP
        
    Else 'If it doesn't exit then create it within the new workbook, rename it and apply the stored range values
        
        With New_WB.Worksheets.Add
        
            .Move Before:=WS1
            .Name = CStr(X)
            
            Set New_WS = New_WB.Workbooks(WS1.Index - 1)
            
        End With
        
        Err.Clear 'clear the generated error
        
    End If
    
    If X > 1 Then New_WS.Range(RRR.Address) = RRR 'apply range from sheet "1"


Next X


With New_WB


    ThisWorkbook.Worksheets("Monthly Report").Copy Before:=.Worksheets(1) 'Copy Monthly Report to new Worksheet
    
    .Worksheets("2").Range("C4:D4") = Target_Month_Day_1 + 1 'second day of the next month


    .Worksheets("Monthly Report").Range("B10") = Target_Month_Day_1 'First Day of upcoming Month
    
End With


With Application


    .EnableEvents = True
    
    .DisplayAlerts = False
            WS1.Delete
    .DisplayAlerts = True
    
End With


FileN = ThisWorkbook.Path & "\" & "Aspen DPR " & Month(Target_Month_Day_1) & "-" & Mid(Year(Target_Month_Day_1), 3, 2) & ".xlsb"


New_WB.SaveAs Filename:=FileN, FileFormat:=xlExcel12


End Sub
Sub CopyModules(wbSource As Workbook, wbTarget As Workbook)


Dim vbcompSource As VBComponent, vbcompTarget As VBComponent


Dim sText As String, nType As Long


For Each vbcompSource In wbSource.VBProject.VBComponents
    nType = vbcompSource.Type
    If nType < 100 Then '100=vbext_ct_Document -- the only module type we would not want to copy
        Set vbcompTarget = wbTarget.VBProject.VBComponents.Add(nType)
        sText = vbcompSource.CodeModule.Lines(1, vbcompSource.CodeModule.CountOfLines)
        vbcompTarget.CodeModule.AddFromString (sText)
        vbcompTarget.Name = vbcompSource.Name
    End If
Next vbcompSource


End Sub
 
Upvote 0

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)
I think may have taken a step backwards. This is probably my fault for not knowing the correct vba verbiage. In terms of relationship to the creation of a new workbook from the existing active workbook, the "New Monthly Workbook" or "Month_Stuff" script as you previously reffered to it can't rely on the well test data transfer because a new well test may not be run on the 1st of the month. The Well Test data should just simply carry over from the active workbook "1" worksheet to the "2" through "31" (December for example) worksheets in the newly created workbook. Along with all of the other commands previously discussed. This will be assigned to a button, which is located only on worksheet titled "1". This button is located only on this sheet and is separate from the "Transfer Well Test Data" button.

In terms of stand alone Well Test Data Transfer from one sheet within the active workbook (current month) to all days going forward in the same active workbook (current month), this should be an entirely different macro which be assigned to an entirely different button which is present on all sheets representing a day of the month.
 
Upvote 0
chadgaspard said:
I think may have taken a step backwards. This is probably my fault for not knowing the correct vba verbiage. In terms of relationship to the creation of a new workbook from the existing active workbook, the "New Monthly Workbook" or "Month_Stuff" script as you previously reffered to it can't rely on the well test data transfer because a new well test may not be run on the 1st of the month. The Well Test data should just simply carry over from the active workbook "1" worksheet to the "2" through "31" (December for example) worksheets in the newly created workbook. Along with all of the other commands previously discussed. This will be assigned to a button, which is located only on worksheet titled "1". This button is located only on this sheet and is separate from the "Transfer Well Test Data" button.

In terms of stand alone Well Test Data Transfer from one sheet within the active workbook (current month) to all days going forward in the same active workbook (current month), this should be an entirely different macro which be assigned to an entirely different button which is present on all sheets representing a day of the month.
Click to expand...

For the previous macro I posted, Well_Test_Data would DO different things depending on whether or not it was called while on sheet "1". If not called while on sheet "1" then it would copy the specified range and place it on all worksheets starting on the current sheet +1 to the end of the numbered worksheets and then include "1" at the end.

If called from while on sheet "1" it would copy the needed worksheets to a new workbook and then overwrite the specified range on each valid worksheet with the range found on sheet "1".

With the following, the actions of the two scripts are no longer linked under the same macro

Well Transfer_Well_Test will do the same thing if called from a valid worksheet and New_Monthly_Workbook will copy the range found on sheet "1" to the other valid sheets when the new workbook is created.

Code: 
Sub Transfer_Well_Test()

'SAVE BEFORE USING THIS TO MAKE SURE IT DOES WHAT YOU WANT PROPERLY

Dim WS As Worksheet, Starting_Worksheet As Long, Original_Worksheet As Worksheet, Range_Data As Range

'Day_Number = Date - DateSerial(Year(Date), Month(Date), 1) + 1 'day number

Set Original_Worksheet = ActiveWorkbook.ActiveSheet

With Original_Worksheet
   
    If IsNumeric(.Name) Then
             
        If CLng(.Name) <= 31 Then
            Set Range_Data = .Range("A43:N43") 'store this range in a variable
        Else
            MsgBox "Invalid worksheet day"
        
            End 'exit all subs        End If
        End If
        
    Else
    
        MsgBox "Invalid starting sheet"
        
        End 'exit all subs
        
    End If
    
End With
                                        'Then apply range to all other valid worksheets
For Each WS In ActiveWorkbook.Worksheets 'loop through worksheets

    With WS

        If Not WS Is Original_Worksheet And IsNumeric(.Name) Then

            If (CLng(.Name) > CLng(Original_Worksheet.Name) Or CLng(.Name) = 1) And CLng(.Name) <= 31 Then .Range(Range_Data.Address) = Range_Data

        End If

    End With

Next WS

End Sub
Sub New_Monthly_Workbook() 'This sub is run from worksheet "1"

Dim Target_Month_Days, Target_Month_Day_1 As Date, X As Long, WS1 As Worksheet, New_WB As Workbook, _
FileN As String, ERR_WS As Worksheet, New_WS As Worksheet, SHP As Shape, RRR As Range
 
Target_Month_Day_1 = DateSerial(Year(Date), Month(Date) + 1, 1) 'first day of next month

'Target_Month_Day_1 = DateSerial(2019, 12, 1) 'first day of Target Month if needed

Target_Month_Days = DateSerial(Year(Target_Month_Day_1), Month(Target_Month_Day_1) + 1, 1) - Target_Month_Day_1
                    
'first day of (Target_Month_Day_1 + 1 MONTH) - Target_Month_Day_1 = number of days in Tareget Month

Application.EnableEvents = False

Set New_WB = Workbooks.Add 'create new workbook and store object in a variable

Set WS1 = New_WB.Worksheets(1) 'first worksheet of the newly created workbook

CopyModules ThisWorkbook, New_WB

On Error Resume Next

For X = 1 To Target_Month_Days 'loop 1 to the number of days found in the target month

    Set ERR_WS = ThisWorkbook.Worksheets(CStr(X)) 'this will generate an error if it doesn't exist
    
    If Err.Number = 0 Then 'if the worksheet exists then copy it to the new Workbook
        
        If X = 1 Then
            ERR_WS.Copy After:=WS1
            Set New_WS = New_WB.Workbooks(WS1.Index + 1)
            Set RRR = New_WS.Range("A43:N43")
        Else
            ERR_WS.Copy Before:=WS1
            Set New_WS = New_WB.Workbooks(WS1.Index - 1)
        End If
        
        For Each SHP In New_WS.Shapes 'change macro reference of shapes to reference the newly created workbook
            SHP.OnAction = Replace(SHP.OnAction, ThisWorkbook.Name, New_WB.Name)
        Next SHP
        
    Else 'If it doesn't exit then create it within the new workbook, rename it and apply the stored range values
        
        With New_WB.Worksheets.Add
        
            .Move Before:=WS1
            .Name = CStr(X)
            
            Set New_WS = New_WB.Workbooks(WS1.Index - 1)
            
        End With
        
        Err.Clear 'clear the generated error
        
    End If
    
    If X > 1 Then New_WS.Range(RRR.Address) = RRR 'apply range from sheet "1"

Next X

With New_WB

    ThisWorkbook.Worksheets("Monthly Report").Copy Before:=.Worksheets(1) 'Copy Monthly Report to new Worksheet
    
    .Worksheets("2").Range("C4:D4") = Target_Month_Day_1 + 1 'second day of the next month

    .Worksheets("Monthly Report").Range("B10") = Target_Month_Day_1 'First Day of upcoming Month
    
End With

With Application

    .EnableEvents = True
    
    .DisplayAlerts = False
            WS1.Delete
    .DisplayAlerts = True
    
End With

FileN = ThisWorkbook.Path & "\" & "Aspen DPR " & Month(Target_Month_Day_1) & "-" & Mid(Year(Target_Month_Day_1), 3, 2) & ".xlsb"

New_WB.SaveAs Filename:=FileN, FileFormat:=xlExcel12

End Sub
Sub CopyModules(wbSource As Workbook, wbTarget As Workbook)

Dim vbcompSource As VBComponent, vbcompTarget As VBComponent

Dim sText As String, nType As Long

For Each vbcompSource In wbSource.VBProject.VBComponents
    nType = vbcompSource.Type
    If nType < 100 Then '100=vbext_ct_Document -- the only module type we would not want to copy
        Set vbcompTarget = wbTarget.VBProject.VBComponents.Add(nType)
        sText = vbcompSource.CodeModule.Lines(1, vbcompSource.CodeModule.CountOfLines)
        vbcompTarget.CodeModule.AddFromString (sText)
        vbcompTarget.Name = vbcompSource.Name
    End If
Next vbcompSource

End Sub
 
Last edited:
Upvote 0
I re-recorded the Month_Stuff macro. Its just missing the ability to accurately add or take away sheets based off of days in the upcoming month as well as the ability to carry over the "Transfer_Well_Test" and Month_stuff" macros

Code:

[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Month_stuff()
'
' Month_stuff Macro
'[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]'
Sheets(Array("Monthly Report", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", _
"13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "1")).Select
Sheets("1").Activate
Sheets(Array("25", "26", "27", "28", "29", "30")).Select Replace:=False
Sheets(Array("Monthly Report", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", _
"13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "1")).Select
Sheets("1").Activate
Sheets(Array("25", "26", "27", "28", "29", "30")).Select Replace:=False
Sheets(Array("Monthly Report", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", _
"13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28" _
, "29", "30", "1")).Copy
Range("B10").Select
ActiveCell.FormulaR1C1 = "12/1/2019"
Range("B11").Select
Sheets("2").Select
Range("C4:D4").Select
ActiveCell.FormulaR1C1 = "='1'!R[2]C[16]"
Range("C5:D5").Select
ActiveWindow.SmallScroll Down:=30
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets("1").Select
ActiveWindow.SmallScroll Down:=27
Range("A47:N53").Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Sheets("2").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("3").Select
ActiveWindow.SmallScroll Down:=9
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("4").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("5").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("6").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("7").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("8").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("9").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("10").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("11").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("12").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("13").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("14").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("15").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("16").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("17").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("18").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("19").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("20").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("21").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("22").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("23").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("24").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("25").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("26").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("27").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("28").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("29").Select
ActiveWindow.SmallScroll Down:=15
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("30").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("30").Select
Application.CutCopyMode = False
Sheets("30").Copy Before:=Sheets(31)
Sheets("30 (2)").Select
Sheets("30 (2)").Name = "31"
ActiveWindow.SmallScroll Down:=-39
Range("C4:D4").Select
ActiveCell.FormulaR1C1 = "='30'!RC:RC[1]+1"
Range("C5:D5").Select
Sheets("1").Select
ActiveWindow.SmallScroll Down:=-45
Range("C4:D4").Select
ActiveCell.FormulaR1C1 = "='31'!RC:RC[1]+1"
Range("C5:D5").Select
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Sheets("Monthly Report").Select
Range("B10").Select
ActiveCell.FormulaR1C1 = "='1'!R[-4]C[17]-1"
Range("B11").Select
Sheets("2").Select
ActiveWindow.SmallScroll Down:=-12
End Sub
[/FONT]
 
Upvote 0
Tremendous thank you to MoshiM! This person was very patient and extremely helpful. Though I am very new to macros and still quite lost, I learned a lot in this process. Final code that made this happen:

"Transfer Well Test" within current month. Still needs work to make it execute more efficiently, but does it's job.

[TABLE="width: 500"]
<tbody>[TR]
[TD][FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Transfer_Well_Test()
'
' Transfer_Well_Test Macro
'[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]'
Range("A47:N53").Select
Selection.Copy
Sheets("3").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("4").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("5").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("6").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("7").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("8").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("9").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("10").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("11").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("12").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("13").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("14").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("15").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("16").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("17").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("18").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("19").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("20").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("21").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("22").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("23").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("24").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("25").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("26").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("27").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("28").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("29").Select
Range("A47:N53").Select
ActiveSheet.Paste
Sheets("30").Select
Range("A47:N53").Select
ActiveSheet.Paste
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets("1").Select
ActiveWindow.SmallScroll Down:=27
Range("A47:N53").Select
ActiveSheet.Paste
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Sheets("2").Select
Application.CutCopyMode = False
End Sub[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub CopyModules(wbSource As Workbook, wbTarget As Workbook)[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Dim vbcompSource As VBComponent, vbcompTarget As VBComponent[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Dim sText As String, nType As Long[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
For Each vbcompSource In wbSource.VBProject.VBComponents
nType = vbcompSource.Type
If nType < 100 Then '100=vbext_ct_Document -- the only module type we would not want to copy
Set vbcompTarget = wbTarget.VBProject.VBComponents.Add(nType)
sText = vbcompSource.CodeModule.Lines(1, vbcompSource.CodeModule.CountOfLines)
vbcompTarget.CodeModule.AddFromString (sText)
vbcompTarget.Name = vbcompSource.Name
End If
Next vbcompSource[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
End Sub
Sub Update_SITP()
'
' Update_SITP Macro
'[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]'
Range("L39:N44").Select
Selection.Copy
Sheets("3").Select
Range("L39:N40").Select
ActiveSheet.Paste
Sheets("4").Select
Range("L39:N44").Select
ActiveSheet.Paste
Sheets("5").Select
ActiveSheet.Paste
Sheets("6").Select
ActiveSheet.Paste
Sheets("7").Select
ActiveSheet.Paste
Sheets("8").Select
ActiveSheet.Paste
Sheets("9").Select
ActiveSheet.Paste
Sheets("10").Select
ActiveSheet.Paste
Sheets("11").Select
ActiveSheet.Paste
Sheets("12").Select
ActiveSheet.Paste
Sheets("13").Select
ActiveSheet.Paste
Sheets("14").Select
ActiveSheet.Paste
Sheets("15").Select
ActiveSheet.Paste
Sheets("16").Select
ActiveSheet.Paste
Sheets("17").Select
ActiveSheet.Paste
Sheets("18").Select
ActiveSheet.Paste
Sheets("19").Select
ActiveSheet.Paste
Sheets("20").Select
ActiveSheet.Paste
Sheets("21").Select
ActiveSheet.Paste
Sheets("22").Select
ActiveSheet.Paste
Sheets("23").Select
ActiveSheet.Paste
Sheets("24").Select
ActiveSheet.Paste
Sheets("25").Select
ActiveSheet.Paste
Sheets("26").Select
ActiveSheet.Paste
Sheets("27").Select
ActiveSheet.Paste
Sheets("28").Select
ActiveSheet.Paste
Sheets("29").Select
ActiveSheet.Paste
Sheets("30").Select
ActiveSheet.Paste
Range("L39:N44").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=9
Range("P48:R53").Select
Application.CutCopyMode = False
Selection.ClearContents
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("L39:N44").Select
Selection.Copy
Sheets("1").Select
Range("L39:N44").Select
ActiveSheet.Paste
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
End Sub
[/FONT]
<strike></strike>
[/TD]
[/TR]
</tbody>[/TABLE]
<strike></strike>

Prepare Next Month's Daily Production Report, move over latest Well Test Data, move over Macros, and Update Shut-in Tubing Pressure

[TABLE="width: 500"]
<tbody>[TR]
[TD][FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Month_Stuff()[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Dim Target_Month_Days, Target_Month_Day_1 As Date, X As Long, WS1 As Worksheet, New_WB As Workbook, _
FileN As String, ERR_WS As Worksheet, RRR As Range

Transfer_Well_Test RRR[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Target_Month_Day_1 = DateSerial(Year(Date), Month(Date) + 1, 1) 'first day of next month[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
'Target_Month_Day_1 = DateSerial(2019, 12, 1) 'first day of Target Month if needed[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Target_Month_Days = DateSerial(Year(Target_Month_Day_1), Month(Target_Month_Day_1) + 1, 1) - Target_Month_Day_1

'first day of (Target_Month_Day_1 + 1 MONTH) - Target_Month_Day_1 = number of days in Tareget Month

Set New_WB = Workbooks.Add 'create new workbook and store object in a variable[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Set WS1 = New_WB.Worksheets(1) 'first worksheet of the newly created workbook[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Application.EnableEvents = False[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
On Error Resume Next[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
For X = 1 To Target_Month_Days 'loop 1 to the number of days found in the target month[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Set ERR_WS = ThisWorkbook.Worksheets(CStr(X)) 'this will generate an error if it doesn't exist

If Err.Number = 0 Then 'if the worksheet exists then copy it to the new Workbook

If X = 1 Then
ERR_WS.Copy After:=WS1
Else
ERR_WS.Copy Before:=WS1
End If

Else 'If it doesn't exit then create it within the new workbook and rename it

With New_WB.Worksheets.Add
.Move Before:=WS1
.Name = CStr(X)
.Range(RRR.Address) = RRR
End With

Err.Clear 'clear the generated error

End If[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Next X[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
With New_WB[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
ThisWorkbook.Worksheets("Monthly Report").Copy Before:=.Worksheets(1) 'Copy Monthly Report to new Worksheet

.Worksheets("2").Range("C4:D4") = DateSerial(Year(Target_Month_Day_1), Month(Target_Month_Day_1), 2) 'second day of the next month[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
.Worksheets("Monthly Report").Range("B10") = DateSerial(Year(Target_Month_Day_1), Month(Target_Month_Day_1), 1) 'First Day of upcoming Month

End With[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
With Application[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
.EnableEvents = True

.DisplayAlerts = False
WS1.Delete
.DisplayAlerts = True

End With
CopyModules ThisWorkbook, New_WB[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]FileN = ThisWorkbook.Path & "" & "Aspen DPR " & Month(Target_Month_Day_1) & "-" & Mid(Year(Target_Month_Day_1), 3, 2) & ".xlsb"[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
New_WB.SaveAs Filename:=FileN, FileFormat:=xlExcel12[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
End Sub[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub Transfer_Well_Test(ByRef RR As Range)[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
'SAVE BEFORE USING THIS TO MAKE SURE IT DOES WHAT YOU WANT PROPERLY[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Dim WS As Worksheet[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Set RR = ActiveWorkbook.ActiveSheet.Range("A47:N53") 'store this range in a variable[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
For Each WS In ActiveWorkbook.Worksheets

With WS

If Not WS Is ActiveWorkbook.ActiveSheet And IsNumeric(.Name) Then

If CLng(.Name) <= 31 Then .Range("A47:N53") = RR

End If

End With

Next[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
End Sub[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub CopyModules(wbSource As Workbook, wbTarget As Workbook)[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
Dim vbcompSource As VBComponent, vbcompTarget As VBComponent
Dim sText As String, nType As Long

For Each vbcompSource In wbSource.VBProject.VBComponents
nType = vbcompSource.Type
If nType < 100 Then '100=vbext_ct_Document -- the only module type we would not want to copy
Set vbcompTarget = wbTarget.VBProject.VBComponents.Add(nType)
sText = vbcompSource.CodeModule.Lines(1, vbcompSource.CodeModule.CountOfLines)
vbcompTarget.CodeModule.AddFromString (sText)
vbcompTarget.Name = vbcompSource.Name
End If
Next vbcompSource

End Sub[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif][/FONT]
<strike></strike>
[/TD]
[/TR]
</tbody>[/TABLE]
<strike></strike>
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Open, Copy data and Close a workbook based on the names of the tabs in my active workbook
Replies
2
Views
122
Aurore87
A
D
  • Solved
Need help creating a formula based on VBA function!
Replies
5
Views
369
Trixterz
T
I
  • Solved
Create daily tabs for a whole month
2
Replies
15
Views
2K
Joe4
Joe4
G
  • Question Question
Using a set date to prevent access to Excell tabs and macros
Replies
1
Views
231
Micron
M
S
  • Question Question
VBA Code that extracts multiple tabs at a time based on lookup tab
2
Replies
10
Views
561
NoSparks
N

Forum statistics

Threads
1,224,747
Messages
6,180,712
Members
452,995
Latest member
isldboy

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top