Automate extraction of data VBA issues

A

Aberdham

Board Regular
Joined
Mar 8, 2018
Messages
163
Office Version
  1. 365
Platform
  1. Windows
Hi Mr. excels,

I am quite new to VBA, and every week I receive an excel file that contains all the data of our sales which needs to be reconcile, I would like to have a VBA code that extract all the data from the sales file to a new workbook. I did find a VBA that suits more or less to my requirement, but I can't seem to get it to work. I hope that all you excel legends here can assist me in modifying the code.

Code: 
[COLOR=#000000][FONT=-webkit-standard]Option Explicit[/FONT][/COLOR]

[COLOR=#000000][FONT=-webkit-standard]Sub findData()[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    'Let's define the variables[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    Dim GCell As Range[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    Dim Txt$, MyPath$, MyWB$, MySheet$[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    Dim myValue As Integer[/FONT][/COLOR]

[COLOR=#000000][FONT=-webkit-standard]    'Search what[/FONT][/COLOR]
[COLOR=#ff0000][FONT=-webkit-standard]Txt = InputBox("What do you want to search for?") 
[/FONT][/COLOR]
can I get rid of this part by extract all the data instead of asking what I want to search for?

[COLOR=#000000][FONT=-webkit-standard]    'The path to the workbook to be searched[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    MyPath = "C:\raw-data"[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    'The name of the workbook to be searched[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    MyWB = "data.xlsx"[/FONT][/COLOR]

[COLOR=#000000][FONT=-webkit-standard]    'Use the current sheet to store the found data[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    MySheet = ActiveSheet.Name[/FONT][/COLOR]

[COLOR=#000000][FONT=-webkit-standard]    'use error handling routine in case of errors[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    On Error GoTo ErrorHandler[/FONT][/COLOR]

[COLOR=#000000][FONT=-webkit-standard]    'Turn off screen updating to run macro faster[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    Application.ScreenUpdating = False[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    Workbooks.Open Filename:=MyPath & MyWB[/FONT][/COLOR]

[COLOR=#000000][FONT=-webkit-standard]    'Search for the specified data[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    Set GCell = ActiveSheet.Cells.Find(Txt)[/FONT][/COLOR]

[COLOR=#000000][FONT=-webkit-standard]    'Record values in current workbook[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    With ThisWorkbook.ActiveSheet.Range("A1")[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]        .Value = "SN"[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]        .Offset(0, 1).Value = "month"[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]        .Offset(1, 0).Value = GCell.Value[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]        myValue = GCell.Offset(0, 1).Value[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]        If myValue >= 6 Then[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]        .Offset(1, 1).Value = GCell.Offset(0, 1).Value[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]        End If[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]        .Columns.AutoFit[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]        .Offset(1, 1).Columns.AutoFit[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    End With[/FONT][/COLOR]

[COLOR=#000000][FONT=-webkit-standard]    'Close data workbook; don't save it; turn screen updating back on[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    ActiveWorkbook.Close savechanges:=False[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]    Application.ScreenUpdating = True[/FONT][/COLOR]
[COLOR=#000000][FONT=-webkit-standard]Exit Sub[/FONT][/COLOR]

[TABLE="width: 2122"]
<tbody>[TR]
[TD]SN[/TD]
[TD]Month[/TD]
[TD]Invoice type[/TD]
[TD]Invoice No.[/TD]
[TD]Supplier[/TD]
[TD]Description[/TD]
[TD]Amount[/TD]
[TD]VAT[/TD]
[TD]VAT[/TD]
[TD]Amount[/TD]
[TD]Invoice[/TD]
[TD]Due Date[/TD]
[TD]FX rate[/TD]
[TD]outstandings[/TD]
[TD]Position[/TD]
[TD]DSO[/TD]
[TD]Sales In €[/TD]
[TD]Cost center[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]gross[/TD]
[TD]%[/TD]
[TD]amount[/TD]
[TD]net[/TD]
[TD]Date[/TD]
[/TR]
[TR]
[TD="align: right"]768890[/TD]
[TD="align: right"]Dec-16[/TD]
[TD]sales Invoice[/TD]
[TD]85MC980999[/TD]
[TD]AAA[/TD]
[TD]registratioin_fee_SN768890[/TD]
[TD]$ 4000 ,00[/TD]
[TD="align: right"]0%[/TD]
[TD]$ -[/TD]
[TD]$ 4000 ,00[/TD]
[TD="align: right"]30/12/2014[/TD]
[TD="align: right"]30/12/2014[/TD]
[TD]$ 1,0541[/TD]
[TD]$ -[/TD]
[TD="align: right"]Dec-14[/TD]
[TD][/TD]
[TD="align: right"]3600[/TD]
[TD]ABD[/TD]
[/TR]
[TR]
[TD]UIJIOP[/TD]
[TD="align: right"]Jan-16[/TD]
[TD]sales Invoice[/TD]
[TD]ACDC098789[/TD]
[TD]BBB[/TD]
[TD]registratioin_fee_SNUIJIOP[/TD]
[TD]$ 4000 ,01[/TD]
[TD="align: right"]0%[/TD]
[TD]$ -[/TD]
[TD]$ 4000 ,01[/TD]
[TD="align: right"]05/01/2014[/TD]
[TD="align: right"]18/01/2014[/TD]
[TD]$ 1,0746[/TD]
[TD]$ -[/TD]
[TD="align: right"]Jan-15[/TD]
[TD][/TD]
[TD="align: right"]3600[/TD]
[TD]acc[/TD]
[/TR]
[TR]
[TD]8782JK[/TD]
[TD="align: right"]Jan-16[/TD]
[TD]sales Invoice[/TD]
[TD]16AC099887[/TD]
[TD]CCC[/TD]
[TD]process_fee_SN8782jk[/TD]
[TD]$ 4000 ,02[/TD]
[TD="align: right"]0%[/TD]
[TD]$ -[/TD]
[TD]$ 4000 ,02[/TD]
[TD="align: right"]15/01/2014[/TD]
[TD="align: right"]25/01/2014[/TD]
[TD]$ 1,0914[/TD]
[TD]$ -[/TD]
[TD="align: right"]Feb-15[/TD]
[TD][/TD]
[TD="align: right"]3600[/TD]
[TD="align: right"]9990[/TD]
[/TR]
[TR]
[TD]9898JK[/TD]
[TD="align: right"]Jan-16[/TD]
[TD]sales Invoice[/TD]
[TD]DGHN787890[/TD]
[TD]DDD[/TD]
[TD]General Service Insp. SN9898JK[/TD]
[TD]$ 4000 ,03[/TD]
[TD="align: right"]0%[/TD]
[TD]$ -[/TD]
[TD]$ 4000 ,03[/TD]
[TD="align: right"]18/01/2014[/TD]
[TD="align: right"]17/02/2014[/TD]
[TD]$ 1,0892[/TD]
[TD]$ -[/TD]
[TD="align: right"]Mar-15[/TD]
[TD][/TD]
[TD="align: right"]3600[/TD]
[TD="align: right"]78789[/TD]
[/TR]
[TR]
[TD]9898HJ[/TD]
[TD="align: right"]Jan-16[/TD]
[TD]sales Invoice[/TD]
[TD]17MIKIOLK[/TD]
[TD]AAD[/TD]
[TD]process_fee_SN9898HJ[/TD]
[TD]$ 110.000,00[/TD]
[TD="align: right"]0%[/TD]
[TD]$ -[/TD]
[TD] $ 110.000,00[/TD]
[TD="align: right"]08/01/2015[/TD]
[TD="align: right"]18/01/2015[/TD]
[TD]$ 1,0861[/TD]
[TD]$ -[/TD]
[TD="align: right"]Apr-15[/TD]
[TD][/TD]
[TD="align: right"]3600[/TD]
[TD="align: right"]1111[/TD]
[/TR]
</tbody>[/TABLE]

I would be really grateful if you could help!

best regards,
M



 
Last edited by a moderator:

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Sort by date Sort by votes
Is it possible that you just post what is your beginning state, and what is your ending state? It is more difficult to interpret existing code that is not working correctly, especially if you did not create it yourself.

What is your starting point, and what do you want your end result to look like?
 
Last edited:
Upvote 0
so basically I have 3 sheets with related info about a machine:
there are altogether 120 of them.

sheet 1 (historical cost) would look like:
[TABLE="class: cms_table, width: 1327"]
<tbody>[TR]
[TD]Invoice type[/TD]
[TD]Invoice Number[/TD]
[TD]Supplier/Debitor[/TD]
[TD]Description[/TD]
[TD]Invoice Date[/TD]
[TD]FX rate[/TD]
[TD]USD Amount[/TD]
[TD]EUR Amount[/TD]
[TD]Change in Inventory[/TD]
[TD]Machinery[/TD]
[TD]Category[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]K8554214[/TD]
[TD]ADA[/TD]
[TD]Deposit SN 844451[/TD]
[TD="align: right"]01/12/2017[/TD]
[TD="align: right"]1,1885[/TD]
[TD]$361.067,54[/TD]
[TD="align: right"]303.801,05 €[/TD]
[TD="align: right"]-303.801,05 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]K8554215[/TD]
[TD]ADA[/TD]
[TD]final payment_ESN 848462[/TD]
[TD="align: right"]01/01/2018[/TD]
[TD="align: right"]1,1993[/TD]
[TD]$358.718,75[/TD]
[TD="align: right"]299.106,77 €[/TD]
[TD="align: right"]-299.106,77 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]K8554216[/TD]
[TD]APOM[/TD]
[TD]final payment_ESN 848462[/TD]
[TD="align: right"]02/02/2018[/TD]
[TD="align: right"]1,2492[/TD]
[TD]$ 2.600,60[/TD]
[TD="align: right"]2.081,82 €[/TD]
[TD="align: right"]-2.081,82 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD="align: right"]85426589[/TD]
[TD]APOM[/TD]
[TD]inspection[/TD]
[TD="align: right"]02/02/2018[/TD]
[TD="align: right"]1,2492[/TD]
[TD]$ 3.461,33[/TD]
[TD="align: right"]2.770,84 €[/TD]
[TD="align: right"]-2.770,84 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD="align: right"]85426589[/TD]
[TD]UIJ[/TD]
[TD]opmen[/TD]
[TD="align: right"]02/02/2018[/TD]
[TD="align: right"]1,2492[/TD]
[TD]$ 18.988,94[/TD]
[TD="align: right"]15.200,88 €[/TD]
[TD="align: right"]-15.200,88 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Sheet 2 (sales)

[TABLE="class: cms_table, width: 1699"]
<tbody>[TR]
[TD]Type of invoice[/TD]
[TD]Invoice Number[/TD]
[TD]Supplier/Debitor[/TD]
[TD]Description[/TD]
[TD]Invoice Date[/TD]
[TD]FX rate[/TD]
[TD]USD Amount[/TD]
[TD]EUR Amount[/TD]
[TD]Change in Inventory[/TD]
[TD]Machinery[/TD]
[TD]Category[/TD]
[/TR]
[TR]
[TD]R[/TD]
[TD]AR00214522[/TD]
[TD]ADA[/TD]
[TD]AR00251452[/TD]
[TD="align: right"]11/04/2018[/TD]
[TD="align: right"]1,2384[/TD]
[TD]$ 15.222,00[/TD]
[TD="align: right"]€12.291,67[/TD]
[TD="align: right"]-12.291,67 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


sheet 3( purchase)

[TABLE="class: cms_table, width: 1699"]
<tbody>[TR]
[TD]Type of invoice[/TD]
[TD]Invoice Number[/TD]
[TD]Supplier/Debitor[/TD]
[TD]Description[/TD]
[TD]Invoice Date[/TD]
[TD]FX rate[/TD]
[TD]USD Amount[/TD]
[TD]EUR Amount[/TD]
[TD]Change in Inventory[/TD]
[TD]Machinery[/TD]
[TD]Category[/TD]
[/TR]
[TR]
[TD]P[/TD]
[TD="align: right"]58485[/TD]
[TD]AAD[/TD]
[TD]AP001523[/TD]
[TD="align: right"]11/04/2018[/TD]
[TD="align: right"]1,2384[/TD]
[TD]$ 15.222,00[/TD]
[TD="align: right"]€12.291,67[/TD]
[TD="align: right"]12.291,67 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]P[/TD]
[TD="align: right"]584885[/TD]
[TD]AAR[/TD]
[TD]AP001524[/TD]
[TD="align: right"]01/04/2018[/TD]
[TD="align: right"]1,2321[/TD]
[TD]$ 1.600,00[/TD]
[TD="align: right"]€1.298,60[/TD]
[TD="align: right"]1.298,60 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]P[/TD]
[TD="align: right"]584882[/TD]
[TD]AAE[/TD]
[TD]AP001525[/TD]
[TD="align: right"]01/04/2018[/TD]
[TD="align: right"]1,2321[/TD]
[TD]$ 500,00[/TD]
[TD="align: right"]€405,81[/TD]
[TD="align: right"]405,81 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]P[/TD]
[TD="align: right"]48595[/TD]
[TD]AES[/TD]
[TD]AP001526[/TD]
[TD="align: right"]01/04/2018[/TD]
[TD="align: right"]1,2321[/TD]
[TD]$ 18.455,00[/TD]
[TD="align: right"]€14.978,49[/TD]
[TD="align: right"]14.978,49 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]P[/TD]
[TD="align: right"]485953[/TD]
[TD]AHJ[/TD]
[TD]AP001527[/TD]
[TD="align: right"]01/04/2018[/TD]
[TD="align: right"]1,2321[/TD]
[TD]$ 16.746,00[/TD]
[TD="align: right"]€13.591,43[/TD]
[TD="align: right"]13.591,43 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]P[/TD]
[TD="align: right"]1007019[/TD]
[TD]UIJ[/TD]
[TD]AP001528[/TD]
[TD="align: right"]01/04/2018[/TD]
[TD="align: right"]1,2321[/TD]
[TD]$ 6.200,00[/TD]
[TD="align: right"]€5.050,51[/TD]
[TD="align: right"]5.050,51 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]P[/TD]
[TD="align: right"]1007020[/TD]
[TD]JIMK[/TD]
[TD]AP001529[/TD]
[TD="align: right"]01/04/2018[/TD]
[TD="align: right"]1,2321[/TD]
[TD]$ 35.000,00[/TD]
[TD="align: right"]€28.434,48[/TD]
[TD="align: right"]28.434,48 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]P[/TD]
[TD="align: right"]8958952[/TD]
[TD]KYT[/TD]
[TD]AP001530[/TD]
[TD="align: right"]01/04/2018[/TD]
[TD="align: right"]1,2321[/TD]
[TD]$2.000.000,00[/TD]
[TD="align: right"]€1.617.992,07[/TD]
[TD="align: right"]1.617.992,07 €[/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


I would like to have them transfer to a new sheet named overview Machine 1 (drop down list or pivot table)
could you construct me a VBA code for it?

Thank you in advance.

iliace said:
Is it possible that you just post what is your beginning state, and what is your ending state? It is more difficult to interpret existing code that is not working correctly, especially if you did not create it yourself.

What is your starting point, and what do you want your end result to look like?
Click to expand...
 
Upvote 0
OK, let's tackle these things one at a time. First, let's make sure I understand the problem correctly.

Below is some code. It assumes:
* You have sheets named "historical cost", "sales", and "purchase" - spelled exactly like that
* All data on the above mentioned sheets begins in cell A1 (i.e. "Type of Invoice")
* You have a sheet named "overview"
* In cell C2 of the "overview" sheet, you have the word that represents the column you want to filter, e.g. "Machinery"
* To the right of that cell, you have a value for the column, e.g. "1" - representing "Machinery 1"

See the instructions in bold red, as code comments, to reflect the above.

With that out of the way, now try the following:
1. Paste the code below into a standard module (e.g. Module1) in your workbook
2. Ensure all the requirements are met, as per the list above
3. Enter the Machinery number that you need, on the overview sheet, in cell D2
4. Run the macro titled UpdateOverview

Post back with what happens, how good are the results, any error messages, and so on.

Once you have established that this basic code works as you need, we can work on additional features like a drop-down and so forth.

Here is the code:
Rich (BB code): 
' update this to list your sheets, separate names by comma
Private Const msSHEET_NAMES As String = "historical cost,sales,purchase"
' update this to reflect the name of your Overview sheet
Private Const msOVERVIEW_SHEET As String = "overview"

' on the Overview sheet, specify in this cell which column you are looking for
' for example, in C2, type "Machinery" if that is the list you want
Private Const msOVERVIEW_FILTER_COLUMN_LABEL_RANGE As String = "C2"

' on each of the data sheets, specify the cell where the data range begins
Private Const msBEGIN_DATA_RANGE As String = "A1"


Public Sub UpdateOverview()
  Dim vSheets As Variant
  
  Dim wkb As Excel.Workbook
  
  Dim wshOverview As Excel.Worksheet
  
  Dim sCurrentSheet As String
  Dim wshCurrentSheet As Excel.Worksheet
  
  Dim wshTemp As Excel.Worksheet
  
  Dim i As Long
  
  Dim rngData As Excel.Range
  Dim rngFilter As Excel.Range
  
  Dim rngOverviewOutput As Excel.Range
  
  Dim sColumn As String
  Dim sValue As String

  Dim bResult As Boolean

  vSheets = Split(msSHEET_NAMES, ",")
  
  Set wkb = ThisWorkbook
  
  On Error Resume Next
    Set wshOverview = wkb.Worksheets(msOVERVIEW_SHEET)
  On Error GoTo 0
  
  If wshOverview Is Nothing Then
    Call MsgBox("Sheet '" & msOVERVIEW_SHEET & "' not found!", vbOKOnly + vbCritical, "Error")
    Exit Sub
  End If
  
  Set rngOverviewOutput = wshOverview.Range(msOVERVIEW_FILTER_COLUMN_LABEL_RANGE)
  
  With rngOverviewOutput
    sColumn = .Value
    sValue = .Offset(0, 1).Value
    
    Set rngOverviewOutput = .Offset(3, 2)
  End With
  
  rngOverviewOutput.EntireRow.Resize(rowsize:=rngOverviewOutput.Parent.Rows.Count - rngOverviewOutput.Row).Clear
  
  bResult = False
  For i = LBound(vSheets) To UBound(vSheets)
    sCurrentSheet = Trim(vSheets(i))
    
    On Error GoTo 0
      Set wshCurrentSheet = wkb.Worksheets(sCurrentSheet)
    On Error GoTo 0

    
    If Not (wshCurrentSheet Is Nothing) Then
      Set rngData = wshCurrentSheet.Range("A1").CurrentRegion
      Set rngFilter = rngGetExtract(rngData, sColumn, sValue, _
            IIf(i = LBound(vSheets) Or Not bResult, True, False))
      
      If Not (rngFilter Is Nothing) Then
       
        rngFilter.Copy Destination:=rngOverviewOutput
        rngFilter.Copy: rngOverviewOutput.PasteSpecial xlPasteColumnWidths
        
        Set rngOverviewOutput = rngOverviewOutput.Offset(rngFilter.Rows.Count + 1, 0)
        
        bResult = True
      End If
    End If
  Next i

End Sub


Private Function rngGetExtract(ByVal rngData As Excel.Range, _
                                ByVal sFilterColumn As String, _
                                ByVal sFilterValue As String, _
                                bHeader As Boolean) As Excel.Range

  Dim rngHeaders As Excel.Range
  Dim rngFilter As Excel.Range

  Dim rngOutput As Excel.Range
  Dim rngResult As Excel.Range
  
  Dim rngFind As Excel.Range
  
  
  Set rngHeaders = rngData.Rows(1)
  
  On Error Resume Next
    Set rngFind = rngHeaders.Find(sFilterColumn, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
  On Error GoTo 0
  
  If rngFind Is Nothing Then
    Set rngGetExtract = Nothing
    GoTo cleanup
  End If
  
  Set rngFilter = rngHeaders.Cells(1).Offset(0, rngHeaders.Columns.Count + 2)
  
  With rngFilter
    .EntireColumn.Clear
    .Value = sFilterColumn
    .Offset(1, 0).Value = sFilterValue
  End With
  
  Set rngOutput = rngFilter.Offset(0, 2).Resize(1, rngHeaders.Columns.Count)
  rngOutput.EntireColumn.Clear
  
  rngData.Copy
  
  With rngOutput
    .PasteSpecial xlPasteFormats
    .PasteSpecial xlPasteColumnWidths
    .Value = rngHeaders.Value
  End With
  
  rngData.AdvancedFilter xlFilterCopy, rngFilter.Resize(2, 1), rngOutput
  
  If Application.WorksheetFunction.CountA(rngOutput.Offset(1, 0)) = 0 Then
    Set rngGetExtract = Nothing
    GoTo cleanup
  End If
  
  Set rngResult = Range(rngOutput.Cells(1).Offset(IIf(bHeader, 0, 1), 0), _
        rngOutput.Parent.Cells(rngOutput.Parent.Rows.Count, _
          rngOutput.Cells(1).Column).End(xlUp)).Resize(ColumnSize:=rngOutput.Columns.Count)
  
  Set rngGetExtract = rngResult

cleanup:

End Function
 
Last edited:
Upvote 0
iliace said:
OK, let's tackle these things one at a time. First, let's make sure I understand the problem correctly.

Below is some code. It assumes:
* You have sheets named "historical cost", "sales", and "purchase" - spelled exactly like that
* All data on the above mentioned sheets begins in cell A1 (i.e. "Type of Invoice")
* You have a sheet named "overview"
* In cell C2 of the "overview" sheet, you have the word that represents the column you want to filter, e.g. "Machinery"
* To the right of that cell, you have a value for the column, e.g. "1" - representing "Machinery 1"

See the instructions in bold red, as code comments, to reflect the above.

With that out of the way, now try the following:
1. Paste the code below into a standard module (e.g. Module1) in your workbook
2. Ensure all the requirements are met, as per the list above
3. Enter the Machinery number that you need, on the overview sheet, in cell D2
4. Run the macro titled UpdateOverview

Post back with what happens, how good are the results, any error messages, and so on.

Once you have established that this basic code works as you need, we can work on additional features like a drop-down and so forth.

Here is the code:
Rich (BB code): 
' update this to list your sheets, separate names by comma
Private Const msSHEET_NAMES As String = "historical cost,sales,purchase"
' update this to reflect the name of your Overview sheet
Private Const msOVERVIEW_SHEET As String = "overview"

' on the Overview sheet, specify in this cell which column you are looking for
' for example, in C2, type "Machinery" if that is the list you want
Private Const msOVERVIEW_FILTER_COLUMN_LABEL_RANGE As String = "C2"

' on each of the data sheets, specify the cell where the data range begins
Private Const msBEGIN_DATA_RANGE As String = "A1"


Public Sub UpdateOverview()
  Dim vSheets As Variant
  
  Dim wkb As Excel.Workbook
  
  Dim wshOverview As Excel.Worksheet
  
  Dim sCurrentSheet As String
  Dim wshCurrentSheet As Excel.Worksheet
  
  Dim wshTemp As Excel.Worksheet
  
  Dim i As Long
  
  Dim rngData As Excel.Range
  Dim rngFilter As Excel.Range
  
  Dim rngOverviewOutput As Excel.Range
  
  Dim sColumn As String
  Dim sValue As String

  Dim bResult As Boolean

  vSheets = Split(msSHEET_NAMES, ",")
  
  Set wkb = ThisWorkbook
  
  On Error Resume Next
    Set wshOverview = wkb.Worksheets(msOVERVIEW_SHEET)
  On Error GoTo 0
  
  If wshOverview Is Nothing Then
    Call MsgBox("Sheet '" & msOVERVIEW_SHEET & "' not found!", vbOKOnly + vbCritical, "Error")
    Exit Sub
  End If
  
  Set rngOverviewOutput = wshOverview.Range(msOVERVIEW_FILTER_COLUMN_LABEL_RANGE)
  
  With rngOverviewOutput
    sColumn = .Value
    sValue = .Offset(0, 1).Value
    
    Set rngOverviewOutput = .Offset(3, 2)
  End With
  
  rngOverviewOutput.EntireRow.Resize(rowsize:=rngOverviewOutput.Parent.Rows.Count - rngOverviewOutput.Row).Clear
  
  bResult = False
  For i = LBound(vSheets) To UBound(vSheets)
    sCurrentSheet = Trim(vSheets(i))
    
    On Error GoTo 0
      Set wshCurrentSheet = wkb.Worksheets(sCurrentSheet)
    On Error GoTo 0

    
    If Not (wshCurrentSheet Is Nothing) Then
      Set rngData = wshCurrentSheet.Range("A1").CurrentRegion
      Set rngFilter = rngGetExtract(rngData, sColumn, sValue, _
            IIf(i = LBound(vSheets) Or Not bResult, True, False))
      
      If Not (rngFilter Is Nothing) Then
       
        rngFilter.Copy Destination:=rngOverviewOutput
        rngFilter.Copy: rngOverviewOutput.PasteSpecial xlPasteColumnWidths
        
        Set rngOverviewOutput = rngOverviewOutput.Offset(rngFilter.Rows.Count + 1, 0)
        
        bResult = True
      End If
    End If
  Next i

End Sub


Private Function rngGetExtract(ByVal rngData As Excel.Range, _
                                ByVal sFilterColumn As String, _
                                ByVal sFilterValue As String, _
                                bHeader As Boolean) As Excel.Range

  Dim rngHeaders As Excel.Range
  Dim rngFilter As Excel.Range

  Dim rngOutput As Excel.Range
  Dim rngResult As Excel.Range
  
  Dim rngFind As Excel.Range
  
  
  Set rngHeaders = rngData.Rows(1)
  
  On Error Resume Next
    Set rngFind = rngHeaders.Find(sFilterColumn, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
  On Error GoTo 0
  
  If rngFind Is Nothing Then
    Set rngGetExtract = Nothing
    GoTo cleanup
  End If
  
  Set rngFilter = rngHeaders.Cells(1).Offset(0, rngHeaders.Columns.Count + 2)
  
  With rngFilter
    .EntireColumn.Clear
    .Value = sFilterColumn
    .Offset(1, 0).Value = sFilterValue
  End With
  
  Set rngOutput = rngFilter.Offset(0, 2).Resize(1, rngHeaders.Columns.Count)
  rngOutput.EntireColumn.Clear
  
  rngData.Copy
  
  With rngOutput
    .PasteSpecial xlPasteFormats
    .PasteSpecial xlPasteColumnWidths
    .Value = rngHeaders.Value
  End With
  
  rngData.AdvancedFilter xlFilterCopy, rngFilter.Resize(2, 1), rngOutput
  
  If Application.WorksheetFunction.CountA(rngOutput.Offset(1, 0)) = 0 Then
    Set rngGetExtract = Nothing
    GoTo cleanup
  End If
  
  Set rngResult = Range(rngOutput.Cells(1).Offset(IIf(bHeader, 0, 1), 0), _
        rngOutput.Parent.Cells(rngOutput.Parent.Rows.Count, _
          rngOutput.Cells(1).Column).End(xlUp)).Resize(ColumnSize:=rngOutput.Columns.Count)
  
  Set rngGetExtract = rngResult

cleanup:

End Function
Click to expand...

Hi Iliace,

Thank you for your reply. However, I am a bit confused since I have the column J as Machinery. (1-75)

I have managed to pull all the data from invoice lists sheet into the overview sheet:

Option Explicit
Public Sub CombineDataFromAllSheets()
Dim wksSrc As Worksheet, wksDst As Worksheet
Dim rngSrc As Range, rngDst As Range
Dim lngLastCol As Long, lngSrcLastRow As Long, lngDstLastRow As Long

'Set references up-front
Set wksDst = ThisWorkbook.Worksheets("Overview Machinery 1")
lngDstLastRow = LastOccupiedRowNum(wksDst)
lngLastCol = LastOccupiedColNum(wksDst)

'Set the destination range
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)

'Looping through
For Each wksSrc In ThisWorkbook.Worksheets

If wksSrc.Name <> "Overview Machinery 1" Then

lngSrcLastRow = LastOccupiedRowNum(wksSrc)

'Store all relevant source data then copy it to the destination range
With wksSrc
Set rngSrc = .Range(.Cells(2, 1), .Cells(lngSrcLastRow, lngLastCol))
rngSrc.Copy Destination:=rngDst
End With

'Redefine the destination range that new data has been added
lngDstLastRow = LastOccupiedRowNum(wksDst)
Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)

End If

Next wksSrc
End Sub
'INPUT : Sheet, the worksheet we are going to search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return as 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
'INPUT : Sheet, the worksheet we are going search to find the last column
'OUTPUT : Long, the last occupied column
'SPECIAL CASE: if Sheet is empty, return as 1
Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End With
Else
lng = 1
End If
LastOccupiedColNum = lng
End Function

However, I tried your code and it indicates "variable not defined". and I am stuck with Exporting the related invoices to the respective overview sheet by implementing Column J as identifier.

And I have a bit of a silly question to ask, whenever additional rows is entered, is it possible to automate the new entries instead of run the code again and delete the duplicate rows to include the additional items?

Thanks a lot !
 
Upvote 0
I tried it with the example you posted, and the parameters as listed in my reply - it seems to do what you are asking it to do. Unless I am misunderstanding. The way I set it up is it *looks* for the column Machinery, in case that ever changes. But right now, in my sample as well, the column is J.

As far as "variable not defined", which variable are we talking about?

You can take a look: https://1drv.ms/x/s!AtJ-3Lle_YMHgcQYtM5p2MOFeZJHkQ (download the file to use the macro).
 
Upvote 0
iliace said:
I tried it with the example you posted, and the parameters as listed in my reply - it seems to do what you are asking it to do. Unless I am misunderstanding. The way I set it up is it *looks* for the column Machinery, in case that ever changes. But right now, in my sample as well, the column is J.

As far as "variable not defined", which variable are we talking about?

You can take a look: https://1drv.ms/x/s!AtJ-3Lle_YMHgcQYtM5p2MOFeZJHkQ (download the file to use the macro).
Click to expand...

Ah Thank you for clarifying that Iliace! I see that we have a different Settings.

and it raises my question further, does this code also work when i have 75 Sheets more ? will the respective machinery data fall into the respective Sheets?
 
Upvote 0
iliace said:
I tried it with the example you posted, and the parameters as listed in my reply - it seems to do what you are asking it to do. Unless I am misunderstanding. The way I set it up is it *looks* for the column Machinery, in case that ever changes. But right now, in my sample as well, the column is J.

As far as "variable not defined", which variable are we talking about?

You can take a look: https://1drv.ms/x/s!AtJ-3Lle_YMHgcQYtM5p2MOFeZJHkQ (download the file to use the macro).
Click to expand...

Hey iliace, I noticed you made a duplicate columns (from Column N onwards) of machinery 1 in all the 3 output sheets.
- Is that step mandatory? or is it also possible to transfer the data without making duplicating the data?
- Is it also possible to modify the code and transfer the invoice that falls under the respective machinery overview (see below link)

https://docs.google.com/spreadsheet...VpvimctAdVv5TkPl86h-MijNU4/edit#gid=791779032
 
Upvote 0
iliace said:
I tried it with the example you posted, and the parameters as listed in my reply - it seems to do what you are asking it to do. Unless I am misunderstanding. The way I set it up is it *looks* for the column Machinery, in case that ever changes. But right now, in my sample as well, the column is J.

As far as "variable not defined", which variable are we talking about?

You can take a look: https://1drv.ms/x/s!AtJ-3Lle_YMHgcQYtM5p2MOFeZJHkQ (download the file to use the macro).
Click to expand...
https://1drv.ms/x/s!Aqt4VfikFsyKbXrH7TJdaSfLee8
this should be the correct link.

thanks
 
Upvote 0
Aberdham said:
Hey iliace, I noticed you made a duplicate columns (from Column N onwards) of machinery 1 in all the 3 output sheets.
- Is that step mandatory? or is it also possible to transfer the data without making duplicating the data?
- Is it also possible to modify the code and transfer the invoice that falls under the respective machinery overview (see below link)

https://docs.google.com/spreadsheet...VpvimctAdVv5TkPl86h-MijNU4/edit#gid=791779032
Click to expand...

The duplicate columns are created by the macro. It uses Advanced Filter to get the list of Machinery. It is necessary to create it, but it is just temporary, so it is possible to delete after the result is copied. The code I provided was just a proof of concept - we can refine it if necessary, and add other things like event-driven actions.

Aberdham said:
https://1drv.ms/x/s!Aqt4VfikFsyKbXrH7TJdaSfLee8
this should be the correct link.

thanks
Click to expand...

So are you saying you want to create a new sheet for each Machinery listed? Do they already exist, or do you want to create a new one? If one already exists, do you want to overwrite it?
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

Sufiyan97
  • Solved
VBA Filter Names from List One by One and then Copy filtered data v2
Replies
6
Views
177
Sufiyan97
Sufiyan97
D
  • Question Question
Problems Encountered When Generating VBA Excel Charts with 15-Minute Interval Data.
Replies
0
Views
356
dilshod_k
D
M
  • Question Question
Manipulation of sales data
Replies
1
Views
341
Herakles
H
C
  • Question Question
Formula not working to show total sales per day, #VALUE! Can't find the issue (Ignore Conditionals) I3 works fine, J3&J4 are what I have tried.
2
Replies
15
Views
594
Asbestos_Jen
Asbestos_Jen
D
  • Question Question
Copy rows to a new workbook based on a date range of last three months from today()
Replies
8
Views
523
dandee14k
D

Forum statistics

Threads
1,223,892
Messages
6,175,236
Members
452,621
Latest member
Laura_PinksBTHFT

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