• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA code to format the report and copy paste

Deepa9

Member
Hi All,

I need one help in automating one of my biggest report. it consumes lots of time to prepare this report. below are the steps i follow to do it manually:
1. Copy data from one file to the main file. then we have 3 columns extraa where we have copy paste formulas that is index match formula.
2. Then refresh all the pivots. then do formatting change such as adding border, lines and colour.
3. then copy pivots to other excel file by paste special values and formats to creat summary file.
4. upload these files to the poratal.
can anybody please help me to automate this report. Thanks for your help

Regards,
Deepa
 
Hi,

It seems that you are asking to fly in the sky without any helping object.....

In last 30 days no one's has responded to the post as you haven't share the sample workbook to get it in action.
 
Hi,

Thanks for reply I have attached a sample file with little data. but weekly i need to prepare this kind report by manually copy pasting the data and then copying the formuals then paste special values. atleast if you provide me a macro which can copy the formula and copy pasting the data it would be really great. I have highlighted the formula rows in yellow colour.

Thanks
 

Attachments

  • Sample file.xlsx
    365.5 KB · Views: 21
Hi @Deepa9 ,

You haven't shared the raw file from where you are copying the data by weekly.
Formula part is easy just like a sip of tea as it's nice to see that yo are using table there.

Code:
Sub Formula_Calculate()
Range("Table1[Super Summary]") = _
"=INDEX('Product Hierarchy'!B$1:B$1137,MATCH('Sample data'!$E2,'Product Hierarchy'!$A$1:$A$1137,0))"
Range("Table1[Core Summary]") = _
"=INDEX('Product Hierarchy'!C$1:C$1137,MATCH('Sample data'!$E2,'Product Hierarchy'!$A$1:$A$1137,0))"
Range("Table1[[Super Summary]:[Core Summary]]").Value = Range("Table1[[Super Summary]:[Core Summary]]").Value
End Sub
 
Hi Deepak,
Thanks for the your help, I have attached raw data file which i used to copy and paste manually to detailed file. below are some points:
1. every week i take a new dump and paste the values to detailed file.
2. my question is when i take dump every week do i need to save both files in same folder or how it is.
3. after pasting the data i refresh all pivots.

Thanks
 

Attachments

  • Raw dump.xls
    37 KB · Views: 12
Check this...
1.ok
2. Need to save the both files in same folder
3. Pls adjust the all pivot according to data & use this ActiveWorkbook.RefreshAll @ end of the code


Code:
Option Explicit

Sub Add_Data_From_Raw()
Dim cn As ADODB.Connection, strQuery As String, rst As ADODB.Recordset, strConn As String
Dim source1 As String
Application.ScreenUpdating = False

    'Defines the path of the database
    source1 = ThisWorkbook.Path & "\" & "Raw_Dump.xls" 'you may change it
    If Len(Dir(source1)) = 0 Then
        MsgBox "Dump Not found", vbCritical
        Exit Sub
    End If
   
    Range("Table1").Clear
    ActiveSheet.ListObjects("Table1").Resize Range("$A$1:$K$2")
   
    'Making a connection string
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                            "Data Source=" & source1 & ";" & _
                            "Extended Properties=""Excel 12.0;HDR=Yes"";"

  Set cn = New ADODB.Connection
    cn.Open strConn
   
        'Creating an SQL statement
       strQuery = "SELECT [Year Desc] , [Quarter Desc], [Management Cluster Name], [Cuic], [Popline Id], [Popline Desc]," & _
            "[Lvl 3 HW Top Box/SW Function Desc], [Account ID], [Customer/Inter/Intra] FROM [Dump$A:Q];"
           
        Set rst = New ADODB.Recordset
            rst.Open strQuery, cn, adOpenStatic, adLockReadOnly, adCmdText
            ActiveSheet.Cells(2, 1).CopyFromRecordset rst
        rst.Close
        Set rst = Nothing
    cn.Close
    Set cn = Nothing

    With Range("A1").CurrentRegion
        .Borders.LineStyle = xlContinuous
        .Borders.ColorIndex = xlAutomatic
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Name = "Calibri"
        .Font.FontStyle = "Regular"
        .Font.Size = 11
        Cells.EntireColumn.AutoFit
    End With

Range("Table1[Period]") = "=IFERROR(LOOKUP(RIGHT(B2)*1,{1,2,3,4},{""Jan"",""April"",""July"",""Oct""})&A2,"""")"
Range("Table1[Super Summary]") = _
"=INDEX('Product Hierarchy'!B$1:B$1137,MATCH('Sample data'!$E2,'Product Hierarchy'!$A$1:$A$1137,0))"
Range("Table1[Core Summary]") = _
"=INDEX('Product Hierarchy'!C$1:C$1137,MATCH('Sample data'!$E2,'Product Hierarchy'!$A$1:$A$1137,0))"
Range("Table1[[Period]:[Core Summary]]").Value = Range("Table1[[Period]:[Core Summary]]").Value
Range("Table1").Rows(Range("Table1").Rows.Count).Delete

Range("Table1[Period]").NumberFormat = "[$-409]mmm/yy;@"
Columns.AutoFit
'This will refresh all pivot so need adjust the same need
'ActiveWorkbook.RefreshAll
Application.ScreenUpdating = True
End Sub
 
&
Add a reference to "Microsoft ActiveX Data Objects 2.6 Library"

Tools > References > Check the checkbox in front of "Microsoft ActiveX Data Objects 2.5 Library"
 
Thanks a ton for your reply. I will try this and let you know if i face any challenges. Just for my understading I understand some written VBA codes, but can you please briefly explain steps what does that macro meant for whenever you are free. sorry for troubling you a lot.

Thanks a ton
 
Hi Deepa9,
It's nice to hear that you have curiosity to get it in depth.
I have added more comment in the below macro, let me know it you would to know more.

Code:
Option Explicit

Sub Add_Data_From_Raw()
'declare local variable
Dim cn As ADODB.Connection, strQuery As String, rst As ADODB.Recordset, strConn As String
Dim source1 As String
'stop screen updating
Application.ScreenUpdating = False

'Defines the path of the database from data will be collected
source1 = ThisWorkbook.Path & "\" & "Raw_Dump.xls" 'you may change it

'check file exist or not!!!
If Len(Dir(source1)) = 0 Then
    MsgBox "Dump Not found", vbCritical
    Exit Sub
End If

'clear & resize the table1 to add new data
Range("Table1").Clear
ActiveSheet.ListObjects("Table1").Resize Range("$A$1:$K$2")

'here we will do a sql query to get data from the closed file
'however same could also be process with excel workbook open method
'Making a connection string
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & source1 & ";" & _
        "Extended Properties=""Excel 12.0;HDR=Yes"";"
'set a sql connection
Set cn = New ADODB.Connection

'open sql connection
cn.Open strConn

'create an SQL statement as per data needs to be extracted
'based on sheet name & column header on source file
strQuery = "SELECT [Year Desc] , [Quarter Desc], [Management Cluster Name], [Cuic], [Popline Id], [Popline Desc]," & _
"[Lvl 3 HW Top Box/SW Function Desc], [Account ID], [Customer/Inter/Intra] FROM [Dump$A:Q];"

'set a recorder to get data
Set rst = New ADODB.Recordset
'open recorder
'recordset.Open Source, ActiveConnection, CursorType, LockType, Options
rst.Open strQuery, cn, adOpenStatic, adLockReadOnly, adCmdText

'paste data to A2
ActiveSheet.Cells(2, 1).CopyFromRecordset rst

'close the recorder
rst.Close
'free memory
Set rst = Nothing

'close the connection
cn.Close

'free memory
Set cn = Nothing

'format the data on current sheet
With Range("A1").CurrentRegion
    .Borders.LineStyle = xlContinuous
    .Borders.ColorIndex = xlAutomatic
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Font.Name = "Calibri"
    .Font.FontStyle = "Regular"
    .Font.Size = 11
    Cells.EntireColumn.AutoFit
End With

'apply the formulas

Range("Table1[Period]") = "=IFERROR(LOOKUP(RIGHT(B2)*1,{1,2,3,4},{""Jan"",""April"",""July"",""Oct""})&A2,"""")"

Range("Table1[Super Summary]") = _
"=INDEX('Product Hierarchy'!B$1:B$1137,MATCH('Sample data'!$E2,'Product Hierarchy'!$A$1:$A$1137,0))"

Range("Table1[Core Summary]") = _
"=INDEX('Product Hierarchy'!C$1:C$1137,MATCH('Sample data'!$E2,'Product Hierarchy'!$A$1:$A$1137,0))"

'change formulas to values
Range("Table1[[Period]:[Core Summary]]").Value = Range("Table1[[Period]:[Core Summary]]").Value

'delete last blank row
Range("Table1").Rows(Range("Table1").Rows.Count).Delete

'chnage month format in period col
Range("Table1[Period]").NumberFormat = "[$-409]mmm/yy;@"

'adjust the columns to get it fit
Columns.AutoFit
'This will refresh all pivot so need adjust the same need
'ActiveWorkbook.RefreshAll
'start screen updating
Application.ScreenUpdating = True
End Sub
 
Hi Deepak,

I need one more help on copy pasting the pivots as values and formats in summary report.

Can you please help me with one more VBA code to copy paste the pivots to another summary sheet as paste special values and formats.
I am here by attaching 2 sample files where one file consists pivot and one more has avalue and format paste of pivot.

I have attached just a sample file, if you provide me macro for this I will do the modifications to files as per your suggestion.

The need for this macro is we have many reports with pivots where we need to take pivot and paste values and formats each time. so this can help me to reduce that time.

Thanks much
 

Attachments

  • sample file.xlsx
    13.8 KB · Views: 13
  • summary file.xlsx
    9.5 KB · Views: 8
Check this & let me know if any further changes is required.
Ref from http://www.contextures.com/excel-vba-pivot-table-paste-format.html

Code:
Option Explicit

Sub PivotCopyFormatValues()
Dim ws As Worksheet
Dim pt As PivotTable
Dim rngPT As Range
Dim rngPTa As Range
Dim rngCopy As Range
Dim rngCopy2 As Range
Dim lRowTop As Long
Dim lRowsPT As Long
Dim lRowPage As Long

On Error Resume Next
Range("C1").Select
Selection.End(xlDown).Select
Set pt = ActiveCell.PivotTable
Set rngPTa = pt.PageRange
On Error GoTo errHandler

If pt Is Nothing Then
    MsgBox "Could not copy pivot table for active cell"
    GoTo exitHandler
Else
    Set rngPT = pt.TableRange1
    lRowTop = rngPT.Rows(1).Row
    lRowsPT = rngPT.Rows.Count
    Set ws = Worksheets.Add
    Set rngCopy = rngPT.Resize(lRowsPT - 1)
    Set rngCopy2 = rngPT.Rows(lRowsPT)
   
    rngCopy.Copy Destination:=ws.Cells(lRowTop, 1)
    rngCopy2.Copy Destination:=ws.Cells(lRowTop + lRowsPT - 1, 1)
End If

If Not rngPTa Is Nothing Then
    lRowPage = rngPTa.Rows(1).Row
    rngPTa.Copy Destination:=ws.Cells(lRowPage, 1)
End If
   
ws.Columns.AutoFit

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not copy pivot table for active cell"
    Resume exitHandler
End Sub

Or Check this...

 
Hi Deepak,

Thanks much, the second option is doing it manually which i am already doing.

I will try both codes and let you know if its working fine then Request your help further if i have any doubts.
Thanks in advance
Regards,
Deepa9
 
Hi Deepak,

Can you please help me in modifying the below mentioned macro for copying and pasting from one workbook to another. I have created this for my learning purpose. the problem I am facing is the macro is coping data from same file but its creating new sheet and pasting data. but I want to paste data in Sample_file workbook and on sample data sheet.

Kindly help me with this.

Thanks in advance
 
Code:
Sub U_Raw_Dump()
 
    'prg to copy Raw dump Data
    'Workbooks.Open "D:Raw_dump.xls"
    Dim filename As String
    filename = Application.GetOpenFilename("excel 03 (*.xls),*.xls,excel 07 (*.xlsx),*.xlsx", 1, "select files")
    Workbooks.Open filename
   
    Sheets("sheet1").Select
    Cells.Select
    Selection.Copy
   
    Workbooks.Add
    ActiveSheet.Paste
    ActiveSheet.Name = "Sample data"
    ActiveWorkbook.Save
   
    Windows("Raw_dump.xls").Activate
    ActiveWorkbook.Close
   
End Sub
 
Check this..

Code:
Sub Copy_From_One_to_Another_WB()
Dim copyWB As Workbook, pasteWB As String
Dim ws As Worksheet, copyRange As Range, pasteRange As Range

Application.ScreenUpdating = False
'define copy workbbok, sheet & range
Set copyWB = ThisWorkbook
Set copyRange = copyWB.Sheets("Sheet1").UsedRange

'declare destination workbook
pasteWB = "Sample_file"
'open wb if same is not open
If Isopen(pasteWB) = False Then
    pasteWB = Application.GetOpenFilename("Excel Files(*.xls*),*.xls*", 1, "Select file", , False)
End If
If pasteWB = "False" Then Exit Sub
Workbooks.Open pasteWB

'declare paste rng
Set ws = ActiveSheet
Set pasteRange = ws.Parent.Sheets("sample data").Range(copyRange.Address)

'do do the copy-paste
pasteRange.Value = copyRange.Value

ws.Parent.Save
copyWB.Close True

Application.ScreenUpdating = True
End Sub

Public Function Isopen(strWkbNm As String) As Boolean
    On Error Resume Next
    Dim wBook As Workbook
    Set wBook = Workbooks(strWkbNm)
    If wBook Is Nothing Then    'Not open
        Isopen = False
        Set wBook = Nothing
        On Error GoTo 0
    Else
        Isopen = True
        Set wBook = Nothing
        On Error GoTo 0
    End If
End Function
 
Hi Deepak,

Thanks, one more problem i am facing that is you have given me a macro before to copy paste data from one wokbook to other wokbook and then refresh pivots. I am facing a error that is "Compile error user defined type not defined". please help me to correct this code.

Regards,
 
Code:
Option Explicit
Sub Add_Data_From_Raw()
 
Dim cn As ADODB.Connection, strQuery As String, rst As ADODB.Recordset, strConn As String
Dim source1 As String
Application.ScreenUpdating = False
 
    'Defines the path of the database
  source1 = "D:\Deepa\imp doc\order reports & notes\VBA Test files\Sample_file" & "\" & "D:\Deepa\imp doc\order reports & notes\VBA Test files\Raw_dump.xls" 'you may change it
  If Len(Dir(source1)) = 0 Then
        MsgBox "Dump Not found", vbCritical
        Exit Sub
    End If
 
    Range("Table1").Clear
    ActiveSheet.ListObjects("Table1").Resize Range("$A$1:$K$2")
 
    'Making a connection string
  strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                            "Data Source=" & source1 & ";" & _
                            "Extended Properties=""Excel 12.0;HDR=Yes"";"
 
  Set cn = New ADODB.Connection
    cn.Open strConn
 
        'Creating an SQL statement
      strQuery = "SELECT [Year Desc] , [Quarter Desc], [Management Cluster Name], [Cuic], [Popline Id], [Popline Desc]," & _
            "[Lvl 3 HW Top Box/SW Function Desc], [Account ID], [Customer/Inter/Intra] FROM [Dump$A:Q];"
         
        Set rst = New ADODB.Recordset
            rst.Open strQuery, cn, adOpenStatic, adLockReadOnly, adCmdText
            ActiveSheet.Cells(2, 1).CopyFromRecordset rst
        rst.Close
        Set rst = Nothing
    cn.Close
    Set cn = Nothing
 
    With Range("A1").CurrentRegion
        .Borders.LineStyle = xlContinuous
        .Borders.ColorIndex = xlAutomatic
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Name = "Calibri"
        .Font.FontStyle = "Regular"
        .Font.Size = 11
        Cells.EntireColumn.AutoFit
    End With
 
Range("Table1[Period]") = "=IFERROR(LOOKUP(RIGHT(B2)*1,{1,2,3,4},{""Jan"",""April"",""July"",""Oct""})&A2,"""")"
Range("Table1[Super Summary]") = _
"=INDEX('Product Hierarchy'!B$1:B$1137,MATCH('Sample data'!$E2,'Product Hierarchy'!$A$1:$A$1137,0))"
Range("Table1[Core Summary]") = _
"=INDEX('Product Hierarchy'!C$1:C$1137,MATCH('Sample data'!$E2,'Product Hierarchy'!$A$1:$A$1137,0))"
Range("Table1[[Period]:[Core Summary]]").Value = Range("Table1[[Period]:[Core Summary]]").Value
Range("Table1").Rows(Range("Table1").Rows.Count).Delete
 
Range("Table1[Period]").NumberFormat = "[$-409]mmm/yy;@"
Columns.AutoFit
'This will refresh all pivot so need adjust the same need
'ActiveWorkbook.RefreshAll
Application.ScreenUpdating = True
End Sub
 
Hi Deepak,

Thank you, I have done changes as per your instructions. but still I am getting run time error 52. Bad file name or number. I am not understanding how to fix this issue. I have given the file destinations and everything, I have added the macro here which you have given but only I have given the destinations. where you have mentioned source 1 that is sample file. and raw dump i have given that destination. request you to please check and suggest me the changes are.
If Len(Dir(source1)) = 0 Then
I am getting error for this above line

Thanks in advance
 
Code:
Option Explicit
Sub Add_Data_From_Raw()
 
Dim cn As ADODB.Connection, strQuery As String, rst As ADODB.Recordset, strConn As String
Dim source1 As String
Application.ScreenUpdating = False
 
    'Defines the path of the database
  source1 = "D:\Deepa\imp doc\order reports & notes\VBA Test files\Sample_file" & "\" & "D:\Deepa\imp doc\order reports & notes\VBA Test files\Raw_dump.xls" 'you may change it
  If Len(Dir(source1)) = 0 Then
        MsgBox "Dump Not found", vbCritical
        Exit Sub
    End If
 
    Range("Table1").Clear
    ActiveSheet.ListObjects("Table1").Resize Range("$A$1:$K$2")
 
    'Making a connection string
  strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                            "Data Source=" & source1 & ";" & _
                            "Extended Properties=""Excel 12.0;HDR=Yes"";"
 
  Set cn = New ADODB.Connection
    cn.Open strConn
 
        'Creating an SQL statement
      strQuery = "SELECT [Year Desc] , [Quarter Desc], [Management Cluster Name], [Cuic], [Popline Id], [Popline Desc]," & _
            "[Lvl 3 HW Top Box/SW Function Desc], [Account ID], [Customer/Inter/Intra] FROM [Dump$A:Q];"
      
        Set rst = New ADODB.Recordset
            rst.Open strQuery, cn, adOpenStatic, adLockReadOnly, adCmdText
            ActiveSheet.Cells(2, 1).CopyFromRecordset rst
        rst.Close
        Set rst = Nothing
    cn.Close
    Set cn = Nothing
 
    With Range("A1").CurrentRegion
        .Borders.LineStyle = xlContinuous
        .Borders.ColorIndex = xlAutomatic
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Name = "Calibri"
        .Font.FontStyle = "Regular"
        .Font.Size = 11
        Cells.EntireColumn.AutoFit
    End With
 
Range("Table1[Period]") = "=IFERROR(LOOKUP(RIGHT(B2)*1,{1,2,3,4},{""Jan"",""April"",""July"",""Oct""})&A2,"""")"
Range("Table1[Super Summary]") = _
"=INDEX('Product Hierarchy'!B$1:B$1137,MATCH('Sample data'!$E2,'Product Hierarchy'!$A$1:$A$1137,0))"
Range("Table1[Core Summary]") = _
"=INDEX('Product Hierarchy'!C$1:C$1137,MATCH('Sample data'!$E2,'Product Hierarchy'!$A$1:$A$1137,0))"
Range("Table1[[Period]:[Core Summary]]").Value = Range("Table1[[Period]:[Core Summary]]").Value
Range("Table1").Rows(Range("Table1").Rows.Count).Delete
 
Range("Table1[Period]").NumberFormat = "[$-409]mmm/yy;@"
Columns.AutoFit
'This will refresh all pivot so need adjust the same need
'ActiveWorkbook.RefreshAll
Application.ScreenUpdating = True
End Sub
 
Dear Deepa,

You got confused @ source1 as your path is completely wrong.

open your source excel file & paste below formula in a cell & there what will you get is you source1.

=LEFT(SUBSTITUTE(SUBSTITUTE(CELL("filename"),"[",""),"]",REPT(" ",99)),99)

upload_2014-12-5_21-18-16.png

yellow is the file path which will be source1.
 
Back
Top