Extract Data and Create Reports Automatically in Excel

[nabeelahmed]

Dear Friends, I want to prepare a report with data extract from other sheet with the help of VBA coding. I have attached two sheets one is showing data and the other is showing format what i want to use in that 2nd sheet i want that if i enter Customer Id in Cell F3 and will get data of that specific customer and after that if i want to filter data with specific range i just have to enter date ranges. Please help me to create this report.

 

[vcoolio]

Hello NabeelAhmed,

Try the following code placed in a standard module and assigned to a button:-

Sub Test()

        Dim CustID As String: CustID = Sheet3.[F3].Value
        Dim FromDt As Long: FromDt = Sheet3.[C3].Value
        Dim ToDt As Long: ToDt = Sheet3.[D3].Value

Application.ScreenUpdating = False

        With Sheet2.[A7].CurrentRegion
                .AutoFilter 1, CustID
                .AutoFilter 4, ">=" & FromDt, xlAnd, "<=" & ToDt
                .Offset(1).EntireRow.Copy Sheet3.Range("A" & Rows.Count).End(3)(2)
                .AutoFilter
        End With

Application.ScreenUpdating = True

End Sub

The column headings in your images appear to be merged. Make sure that these cells are all un-merged as merged cells create havoc with VBA codes. Hence, in the code, I've assumed that the column headings are in row7 in both sheets.

I hope that this helps.

Cheerio,
vcoolio.

 

[CA_Punit]

This can be done through Advanced Filter option also. However if there is changes in the criteria the filter option needs to be visited again which might be a probelm.

 

[nabeelahmed]

Hello NabeelAhmed,

Try the following code placed in a standard module and assigned to a button:-

Sub Test()

        Dim CustID As String: CustID = Sheet3.[F3].Value
        Dim FromDt As Long: FromDt = Sheet3.[C3].Value
        Dim ToDt As Long: ToDt = Sheet3.[D3].Value

Application.ScreenUpdating = False

        With Sheet2.[A7].CurrentRegion
                .AutoFilter 1, CustID
                .AutoFilter 4, ">=" & FromDt, xlAnd, "<=" & ToDt
                .Offset(1).EntireRow.Copy Sheet3.Range("A" & Rows.Count).End(3)(2)
                .AutoFilter
        End With

Application.ScreenUpdating = True

End Sub

The column headings in your images appear to be merged. Make sure that these cells are all un-merged as merged cells create havoc with VBA codes. Hence, in the code, I've assumed that the column headings are in row7 in both sheets.

I hope that this helps.

Cheerio,
vcoolio.

Dear Vcoolio, Thats amazing.. its really great help from you.. I just have two issues 1st- if i press button more than one time data is being added every time which i don't want and the 2nd thing all previous data and formats should be erased once i enter other customer id to get data only the entered customer data should be appeared. Please guide me for these issues..

Thanks & Regrds,

Nabeel

 

[vcoolio]

Hello Nabeel,

Ah. So you would like existing data in Sheet 3 deleted before new data is added and you would also like cells C3,D3 and F3 cleared with each transfer.
Sorry, I should have asked you that in my previous post.

Anyway, here's the code amended to allow for clearing of data in Sheet 3:-

Sub Test()

        Dim CustID As String: CustID = Sheet3.[F3].Value
        Dim FromDt As Long: FromDt = Sheet3.[C3].Value
        Dim ToDt As Long: ToDt = Sheet3.[D3].Value

Application.ScreenUpdating = False
       
        Sheet3.[A7].CurrentRegion.Offset(1).Clear
       
        With Sheet2.[A7].CurrentRegion
                .AutoFilter 1, CustID
                .AutoFilter 4, ">=" & FromDt, xlAnd, "<=" & ToDt
                .Offset(1).EntireRow.Copy Sheet3.Range("A" & Rows.Count).End(3)(2)
                .AutoFilter
        End With
       
        Sheet3.[C3:F3].Clear
       
Application.ScreenUpdating = True

End Sub

Do you want all the data in Sheet2 left alone?

I hope that this helps.

Cheerio,
vcoolio.

 

[nabeelahmed]

Hello Nabeel,

Ah. So you would like existing data in Sheet 3 deleted before new data is added and you would also like cells C3,D3 and F3 cleared with each transfer.
Sorry, I should have asked you that in my previous post.

Anyway, here's the code amended to allow for clearing of data in Sheet 3:-

Sub Test()

        Dim CustID As String: CustID = Sheet3.[F3].Value
        Dim FromDt As Long: FromDt = Sheet3.[C3].Value
        Dim ToDt As Long: ToDt = Sheet3.[D3].Value

Application.ScreenUpdating = False
      
        Sheet3.[A7].CurrentRegion.Offset(1).Clear
      
        With Sheet2.[A7].CurrentRegion
                .AutoFilter 1, CustID
                .AutoFilter 4, ">=" & FromDt, xlAnd, "<=" & ToDt
                .Offset(1).EntireRow.Copy Sheet3.Range("A" & Rows.Count).End(3)(2)
                .AutoFilter
        End With
      
        Sheet3.[C3:F3].Clear
      
Application.ScreenUpdating = True

End Sub

Do you want all the data in Sheet2 left alone?

I hope that this helps.

Cheerio,
vcoolio.

Dear Vcoolio, Thanks for you response.. this code is not working.. by using this code everything of sheet3 disappeared even the the cells border of ID and date range.. Also i want to show data along with borders only no highlights...i don't want any change in sheet2. and one thing more just let me know if we wish to get data from the same sheet2, same rows as we are already getting data but not from all columns if we like to obtain data from specific columns only then what will be the change in coding?


Thanks & Regards,

Nabeel Ahmed

 

[vcoolio]

Hello Nabeel,

............. by using this code everything of sheet3 disappeared ...........

Just remember that I've assumed your headings are in row7 with no merged cells.

........even the the cells border of ID and date range..........

Change this line of code:-

Sheet3.[A7].CurrentRegion.Offset(1).Clear

to

Sheet3.[A7].CurrentRegion.Offset(1).ClearContents

and change this line of code:-

Sheet3.[C3:F3].Clear

to

Sheet3.[C3:F3].ClearContents

Now, as for the rest of your query, could you please upload a dummy sample of your workbook so that I can have something to work with. I can't test with an image. So, upload a dummy sample to a free file sharing site such as Drop Box or WeTransfer and then post the link to your file back here. If your data is sensitive then please use dummy data. Make sure that the sample is an exact replica of your actual workbook.

If you are looking to only copy/paste data from certain columns, then, when you upload your sample, please make it very clear which columns you are only interested in.

Cheerio,
vcoolio.

 

[nabeelahmed]

Hello Nabeel,

............. by using this code everything of sheet3 disappeared ...........

Just remember that I've assumed your headings are in row7 with no merged cells.

........even the the cells border of ID and date range..........

Change this line of code:-

Sheet3.[A7].CurrentRegion.Offset(1).Clear

to

Sheet3.[A7].CurrentRegion.Offset(1).ClearContents

and change this line of code:-

Sheet3.[C3:F3].Clear

to

Sheet3.[C3:F3].ClearContents

Now, as for the rest of your query, could you please upload a dummy sample of your workbook so that I can have something to work with. I can't test with an image. So, upload a dummy sample to a free file sharing site such as Drop Box or WeTransfer and then post the link to your file back here. If your data is sensitive then please use dummy data. Make sure that the sample is an exact replica of your actual workbook.

If you are looking to only copy/paste data from certain columns, then, when you upload your sample, please make it very clear which columns you are only interested in.

Cheerio,
vcoolio.

Dear Vcoolio, As you advised to share file with you. please get file from below given link. I have mention everything in that sheet what i required. Please help me to get it done.

Delivery Note Register3.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

Thanks & Appreciate your support.

Nabeel

 

[vcoolio]

Hello Nabeel,

Here you go:-

Option Explicit
Sub Test()

        Dim ws As Worksheet: Set wsR = Sheets("Report ")
        Dim ws1 As Worksheet: Set wsD = Sheets("Data")
        Dim CustID As String: CustID = wsR.[F3].Value
        Dim FromDt As Long: FromDt = wsR.[C3].Value
        Dim ToDt As Long: ToDt = wsR.[D3].Value
        Dim cAr As Variant, pAr As Variant, nRow As Long
        Dim lr As Long: lr = wsD.Range("A" & Rows.Count).End(xlUp).Row

        cAr = Array("A8:A" & lr, "B8:B" & lr, "D8:D" & lr, "E8:E" & lr, "G8:G" & lr, "I8:I" & lr, "J8:J" & lr, _
        "K8:K" & lr, "Z8:Z" & lr, "AC8:AC" & lr, "AD8:AD" & lr, "AE8:AE" & lr, "AJ8:AJ" & lr, "AO8:AO" & lr)
        pAr = Array("A", "G", "L", "B", "E", "F", "D", "C", "H", "I", "J", "K", "M", "N")
       
        nRow = wsR.Cells(Rows.Count, 1).End(xlUp).Row + 1
       
Application.ScreenUpdating = False

If wsR.Range("C3,D3,F3") = vbNullString Then Exit Sub

With wsD.[A7].CurrentRegion
        .AutoFilter 11, CustID
        With .Offset(1)
        .AutoFilter 5, ">=" & FromDt, xlAnd, "<=" & ToDt
For x = LBound(cAr) To UBound(cAr)
        wsD.Range(cAr(x)).Copy
        wsR.Range(pAr(x) & nRow).PasteSpecial xlValues
Next x
        .AutoFilter
        End With
End With

        wsR.Columns.AutoFit
        wsR.Range("A8:N500").Borders.Weight = xlThin
        wsR.[C3:F3].ClearContents
       
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Please ensure that you manually enter the column headings in the Report sheet. As these need to be there permanently, there is no need for them to be brought over from the Data sheet with each transfer of data.
In the Data sheet, please ensure that Row6 is completely cleared of any data. I believe that you only put data in this row for my reference.

I hope that this helps.

Cheerio,
vcoolio.

 

[vcoolio]

Sorry Nabeel,

I just found a couple of typos in the code above so here it is again:-

Option Explicit
Sub Test()

        Dim wsR As Worksheet: Set wsR = Sheets("Report ")
        Dim wsD As Worksheet: Set wsD = Sheets("Data")
        Dim CustID As String: CustID = wsR.[F3].Value
        Dim FromDt As Long: FromDt = wsR.[C3].Value
        Dim ToDt As Long: ToDt = wsR.[D3].Value
        Dim cAr As Variant, pAr As Variant, nRow As Long, x As Long
        Dim lr As Long: lr = wsD.Range("A" & Rows.Count).End(xlUp).Row
        
        cAr = Array("A8:A" & lr, "B8:B" & lr, "D8:D" & lr, "E8:E" & lr, "G8:G" & lr, "I8:I" & lr, "J8:J" & lr, _
        "K8:K" & lr, "Z8:Z" & lr, "AC8:AC" & lr, "AD8:AD" & lr, "AE8:AE" & lr, "AJ8:AJ" & lr, "AO8:AO" & lr)
        pAr = Array("A", "G", "L", "B", "E", "F", "D", "C", "H", "I", "J", "K", "M", "N")
        
        nRow = wsR.Cells(Rows.Count, 1).End(xlUp).Row + 1
        
Application.ScreenUpdating = False

If wsR.Range("C3,D3,F3") = vbNullString Then Exit Sub

With wsD.[A7].CurrentRegion
        .AutoFilter 11, CustID
        With .Offset(1)
        .AutoFilter 5, ">=" & FromDt, xlAnd, "<=" & ToDt
For x = LBound(cAr) To UBound(cAr)
        wsD.Range(cAr(x)).Copy
        wsR.Range(pAr(x) & nRow).PasteSpecial xlValues
Next x
        .AutoFilter
        End With
End With
        
        wsR.Range("A8:N500").Borders.Weight = xlThin
        wsR.Columns.AutoFit
        wsR.[C3:F3].ClearContents
        
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Please ensure that you manually enter the column headings in the Report sheet. As these need to be there permanently, there is no need for them to be brought over from the Data sheet with each transfer of data.
In the Data sheet, please ensure that Row6 is completely cleared of any data. I believe that you only put data in this row for my reference.


Cheerio,
vcoolio.