Copy/paste dynamic, filtered data + put a column into next row (through macro)

[YourBroLucas]

Howdy dear forum members,

Odd title I agree.

So I have sheet 1, sheet 2, and sheet 3.

• Sheet 1 is the overall data entry dynamic table. Data is added through a User form (button "Add new entry")
• Sheet 2 is where filtered data (per department transactions) is exported through a macro (see below)

The problem: Sheet 1's table is too large. One can't read the transactions' "Description" on column P (long sentences)

Now I'd like to make a dynamic table on sheet 3 with multi-criteria filtered data being exported through a macro.

Here's the catch, and where I need your wisdom:

(Row 1 = headers on all sheets)
On sheet 1, let's say that rows 2 to 10 are from "Department A" (column C) + they also are of the "Goodies" type (column N).

I seek to make drop down lists (select which criterias to be considered): one for "Department" (static) and one for "Types" (subject to changes).
I want to filter and copy paste this automatically AND display column P into next row to make it easily visible.

As an example:

1. Sheet1 row2 => sheet3 row2
2. Sheet1 row2's column P (description) => sheet3 row3
3. Sheet1 row3 => sheet3 row4
4. Sheet1 row3's column P => sheet3 row5
5. etc...

Again, I find it exponentially more complex that sheet1's table expands on a daily basis.

Your thoughts?

• Is it possible?
• Do you see a simpler alternative? (I'd be more than grateful to Beta-test it ^.^)
• Is it a good way to display column P?

Smite me with your knowledge, almighty smiters.

Love from France ♥,
Lucas

Sheet2 export macro (for one single department):

Sheet1 = "Tab_Général"
Sheet2 = "Auto_DICOM" (where DICOM is one of the five departments)
(you also have sheets "Auto_DAP"; "Auto_PVAM" ...)

Option Explicit

Sub ExportFilteredData()

' I. DICOM. Variables
Dim shGen As Worksheet
Dim shDicom As Worksheet
Dim DirDICOM As String

Set shGen = Sheets("Tab_Général")
Set shDicom = Sheets("Auto_DICOM")
DirDICOM = "DICOM"

' I. DICOM. Dynamic range
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range

Set StartCell = Range("A16")

' I. DICOM. Find last row
Worksheets("Tab_Général").UsedRange
LastRow = shGen.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

' I. DICOM. Filter
shGen.Range("A16:P" & LastRow).AutoFilter
shGen.Range("A16:P" & LastRow).AutoFilter Field:=3, Criteria1:=DirDICOM

' I. DICOM. Copy/paste
shGen.Range("A16:P" & LastRow).Select
shGen.Range("A16:P" & LastRow).Copy
shDicom.Range("A16").PasteSpecial Paste:=xlPasteAll

' I. DICOM. Reinitialise
Application.CutCopyMode = False
shGen.AutoFilterMode = False
shGen.ShowAllData

' I. DICOM. Reinitialise the shGen filters (chrono order)
    ActiveWorkbook.Worksheets("Tab_Général").ListObjects("Tableau12").Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Tab_Général").ListObjects("Tableau12").Sort. _
        SortFields.Add Key:=Range("Tableau12[[#All],[Date création]]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Tab_Général").ListObjects("Tableau12").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
End With

' II. Exact same thing for the other 4 departments

' Side note: I found it easier to put a new export on top of the previous one as it is (logically) larger, and creates a simpler macro without changing the results.
' Side note 2: Yes I know this macro is ugly ;:(

 

[YourBroLucas]

I must also add the following:

• I don't necessarily expect to use the same macro structure for sheet3, I just attempted to show my thought process hoping it would make things a bit clearer.
• Sheet1's copy/paste macro exports data on five different sheets at once, for each of the departments.
• Afterwards, I intend to format sheet3 rows to make it clear that the corresponding rows are together (putting them is same frame, full white backgroud, removed gridlines)

 

[YourBroLucas]

Found the solution for step one.

Option Explicit

Sub CustomExport()
  Dim shtGen As Worksheet, shtTotal As Worksheet
  Dim cDir, cType
  Dim lr As Long
  Dim lrt As Long
  Dim r As Range
   
  Set shtGen = ActiveWorkbook.Worksheets("Tab_Général")
  Set shtTotal = ActiveWorkbook.Worksheets("RECAP_TOTAL")

' shtGen show all
  shtGen.ListObjects("Tableau12").Range.AutoFilter Field:=3
  shtGen.ListObjects("Tableau12").Range.AutoFilter Field:=14
  shtGen.ListObjects("Tableau12").Sort.SortFields.Clear
  shtGen.ListObjects("Tableau12").Sort.SortFields.Add Key:=Range("Tableau12[[#All],[Date création]]"), SortOn:= _
  xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        
' Clear former export
  If shtGen.AutoFilterMode Then shtGen.AutoFilterMode = False
  lr = shtGen.Range("C" & Rows.Count).End(3).Row
  shtTotal.Range("A16:P" & Rows.Count).ClearContents
  shtTotal.Range("A16:P" & Rows.Count).ClearFormats
  cDir = shtTotal.Range("B6").Value
  cType = shtTotal.Range("B7").Value
  
  With shtGen.Range("A15:P" & lr)
    If cDir <> "" Then .AutoFilter 3, cDir Else .AutoFilter 3, "*"
    If cType <> "" Then .AutoFilter 14, cType Else .AutoFilter 14, "*"
  End With
  
  If shtGen.Range("C" & Rows.Count).End(3).Row > 16 Then
    shtGen.AutoFilter.Range.Offset(1).Copy shtTotal.Range("A16")
    If shtGen.AutoFilterMode Then shtGen.AutoFilterMode = False
  Else
  End If
  
' shtGen show all + chronological order
  shtGen.ListObjects("Tableau12").Range.AutoFilter Field:=3
  shtGen.ListObjects("Tableau12").Range.AutoFilter Field:=14
  shtGen.ListObjects("Tableau12").Sort.SortFields.Clear
  shtGen.ListObjects("Tableau12").Sort.SortFields.Add Key:=Range("Tableau12[[#All],[Date création]]"), SortOn:= _
  xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
  With shtGen.ListObjects("Tableau12").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
  End With

' Msg if no result
lrt = shtTotal.Range("A" & Rows.Count - 1).End(xlUp).Row
    With shtTotal.Range("A16:P" & lrt)
        If Application.WorksheetFunction.Sum(shtTotal.Range("A16:P" & lrt)) = 0 Then
            MsgBox "Aucun résultat trouvé"
        Else
        End If
    End With

End Sub