T3876_Export Sheets One Workbook CopyModule Each Firm

https://excel-egy.com/forum/t3876
---------------------------------

Sub Export_Sheets_One_Workbook_CopyModule_Each_Firm()
    Dim sh          As Worksheet
    Dim ws          As Worksheet
    Dim wk          As Worksheet
    Dim arrSheets   As Variant
    Dim aData       As Variant
    Dim c           As Range
    Dim sSheets()   As String
    Dim n           As Long

    Application.ScreenUpdating = False
        Set sh = ThisWorkbook.Worksheets("DATA")
        arrSheets = Array("DATA", "Sheet3", "Sheet5", "Sheet8", "Sheet10")

        With sh
            With .Range("K8", .Range("K" & Rows.Count).End(xlUp))
                .AdvancedFilter 1, , , True
                .Offset(1).Copy .Parent.Range("CD1")
            End With
            .ShowAllData
        End With

        For Each ws In Worksheets(arrSheets)
            n = n + 1
            ReDim Preserve sSheets(1 To n)
            sSheets(n) = ws.Name
        Next ws

        Application.DisplayAlerts = False
            For Each c In sh.Range("CD1:CD" & sh.Cells(Rows.Count, "CD").End(xlUp).Row)
                If c.Value <> "" Then
                    Worksheets(sSheets).Copy
                    With ActiveWorkbook
                        Set wk = .Worksheets("DATA")
                        .SaveAs Filename:=ThisWorkbook.Path & "\Output_" & c.Value, FileFormat:=52

                        With wk.Range("A7").CurrentRegion
                            aData = .Offset(1).Value
                            aData = FilterArray(aData, 11, CStr(c.Value), True)
                            .Offset(1).ClearContents
                            .Parent.Range("A8").Resize(UBound(aData, 1), UBound(aData, 2)).Value = aData
                        End With

                        wk.Columns(82).Clear
                        CopyModule ThisWorkbook, "Module2", ActiveWorkbook

                        For Each ws In ActiveWorkbook.Worksheets
                            ws.UsedRange.Value = ws.UsedRange.Value
                        Next ws
                        .Close True
                    End With
                End If
            Next c

            sh.Columns(82).Clear
        Application.DisplayAlerts = True

    Application.ScreenUpdating = True

    MsgBox "Done...", 64
End Sub

Sub CopyModule(sourceWB As Workbook, strModuleName As String, targetWB As Workbook)
    Dim strFolder   As String
    Dim strTempFile As String

    strFolder = sourceWB.Path
    If Len(strFolder) = 0 Then strFolder = CurDir
    strFolder = strFolder & "\"

    strTempFile = strFolder & "~tmpexport.bas"

    On Error Resume Next
        sourceWB.VBProject.VBComponents(strModuleName).Export strTempFile
        targetWB.VBProject.VBComponents.Import strTempFile
        Kill strTempFile
    On Error GoTo 0
End Sub

Function FilterArray(ByVal myRefArr As Variant, ByVal col As Integer, ByVal refValue As String, ByVal equal As Boolean) As Variant
    Dim i           As Long
    Dim j           As Long
    Dim n           As Long

    On Error Resume Next
        n = 1

        If refValue = "" Then
            FilterArray = myRefArr
        Else
            ReDim a(1 To UBound(myRefArr, 1), 1 To UBound(myRefArr, 2))
            For i = 1 To UBound(a, 1)
                If IIf(equal, UCase(myRefArr(i, col)) = UCase(refValue), UCase(myRefArr(i, col)) <> UCase(refValue)) Then
                    For j = 1 To UBound(a, 2)
                        a(n, j) = myRefArr(i, j)
                    Next j
                    n = n + 1
                End If
            Next i

            ReDim b(1 To n - 1, 1 To UBound(a, 2))
            For i = 1 To n - 1
                For j = 1 To UBound(a, 2)
                    b(i, j) = a(i, j)
                Next j
            Next i
            FilterArray = b
        End If
    On Error GoTo 0
End Function