VBA - How to Extract Specific Data from another Workbook

Question

I want to create i script where i can extract specific data from another workbook, I have a source file named "Masterfile"i want to get all data from Column C(Header 3) the value from Column C is 1 if values from Column C is NOT 1 no action done..

Sample:

Header1 | Header2 | Header3 |
blue    | blue    | 1       |
blue    | blue    | 1       |
red     | red     | null    |
red     | red     | null    |
yellow  | yellow  | 1       | 
yellow  | yellow  | 1       | 
yellow  | yellow  |         | 

Output:

Header1 | Header2 | Header3 |
blue    | blue    | 1       |
blue    | blue    | 1       |
yellow  | yellow  | 1       | 
yellow  | yellow  | 1       | 

My Code:

Public Sub createRepairReport(wbNew)

    Dim wksht1 As Worksheet, wksht2 As Worksheet
    Dim outputWksht As Worksheet

    Dim lngLastRow As Long, lngLastMappingRow As Long, lngLastCol As Long
    Dim varCabinet As Variant
    Dim cabinetRng As Range

    Set wksht1 = ThisWorkbook.Sheets("masterfile")
    Set wksht2 = ThisWorkbook.Sheets("mapping")


    Set outputWksht = wbNew.Worksheets.Add
    outputWksht.Name = "Repair Details"

    Application.DisplayAlerts = False

    '*****HEADER START*****
   outputWksht.Cells(1, 1).Value = "OrdStatus"
   outputWksht.Cells(1, 2).Value = "OrdNo"
   outputWksht.Cells(1, 3).Value = "RefNo"
   outputWksht.Cells(1, 4).Value = "FixCode"
   outputWksht.Cells(1, 5).Value = "FixDescription"
   outputWksht.Cells(1, 6).Value = "FindCode"
   outputWksht.Cells(1, 7).Value = "FindDescription"
   outputWksht.Cells(1, 8).Value = "FaultCode"
   outputWksht.Cells(1, 9).Value = "FaultDescription"
   outputWksht.Cells(1, 10).Value = "SvcType"
   outputWksht.Cells(1, 11).Value = "OrdCrtDate"
   outputWksht.Cells(1, 12).Value = "CustAcNo"
   outputWksht.Cells(1, 13).Value = "CustomrName"
   outputWksht.Cells(1, 14).Value = "CustClassn"
   outputWksht.Cells(1, 15).Value = "NetSvcId"
   outputWksht.Cells(1, 16).Value = "InstStDate"
   outputWksht.Cells(1, 17).Value = "BillAddress"
   outputWksht.Cells(1, 18).Value = "InstAddress"
   outputWksht.Cells(1, 19).Value = "ContactName"
   outputWksht.Cells(1, 20).Value = "ContactNo"
   outputWksht.Cells(1, 21).Value = "FranArea"
   outputWksht.Cells(1, 22).Value = "FranDesc"
   outputWksht.Cells(1, 23).Value = "SimSn"
   outputWksht.Cells(1, 24).Value = "SimModel"
   outputWksht.Cells(1, 25).Value = "PhoneSn"
   outputWksht.Cells(1, 26).Value = "PhoneModel"
   outputWksht.Cells(1, 27).Value = "ModemSn"
   outputWksht.Cells(1, 28).Value = "ModemModel"
   outputWksht.Cells(1, 29).Value = "Node3GId"
   outputWksht.Cells(1, 30).Value = "BtsIdCDMA"
   outputWksht.Cells(1, 31).Value = "MDF"
   outputWksht.Cells(1, 32).Value = "CABINET"
   outputWksht.Cells(1, 33).Value = "CAB_d_st"
   outputWksht.Cells(1, 34).Value = "CAB_d_pr"
   outputWksht.Cells(1, 35).Value = "DP"
   outputWksht.Cells(1, 36).Value = "DP_e_pr"
   outputWksht.Cells(1, 37).Value = "DP_add"
   outputWksht.Cells(1, 38).Value = "CAB_add"
   outputWksht.Cells(1, 39).Value = "Contractor"
   outputWksht.Cells(1, 40).Value = "Cluster"
   outputWksht.Cells(1, 41).Value = "Region"
   outputWksht.Cells(1, 42).Value = "DLY_date"
   outputWksht.Cells(1, 43).Value = "COM_date"
   outputWksht.Cells(1, 44).Value = "AcvNotes"
   outputWksht.Cells(1, 45).Value = "Date of Data Extraction"
   outputWksht.Cells(1, 46).Value = "Priority Inspection"
   outputWksht.Cells(1, 47).Value = "Basis for Priority"
   'wrksht 2
   outputWksht.Cells(1, 48).Value = "QA CONTRACTOR"
   outputWksht.Cells(1, 49).Value = "QA Contractor Type"
   outputWksht.Cells(1, 50).Value = "QA REGION"
   outputWksht.Cells(1, 51).Value = "QA REGIONAL AREA"
   outputWksht.Cells(1, 52).Value = "QA COS CLUSTER"
   outputWksht.Cells(1, 53).Value = "QA COS SUB AREA"
   outputWksht.Cells(1, 54).Value = "FO TEAM LEADER"
   outputWksht.Cells(1, 55).Value = "QA Team Leader"
   outputWksht.Cells(1, 56).Value = "QA Inspector"
    '*****HEADER-END*****

    'Set the columns to TEXT format
    outputWksht.Columns(23).NumberFormat = "@"
    outputWksht.Columns(25).NumberFormat = "@"
    outputWksht.Columns(27).NumberFormat = "@"

    lngLastRow = wksht1.Range("A" & wksht1.Rows.Count).End(xlUp).Row

    rownum = 2
    For Index = 2 To lngLastRow

        outputWksht.Range("A" & rownum).Value = wksht1.Range("C" & Index).Value
        outputWksht.Range("B" & rownum).Value = wksht1.Range("D" & Index).Value
        outputWksht.Range("C" & rownum).Value = wksht1.Range("E" & Index).Value
        outputWksht.Range("D" & rownum).Value = wksht1.Range("G" & Index).Value
        outputWksht.Range("E" & rownum).Value = wksht1.Range("H" & Index).Value
        outputWksht.Range("F" & rownum).Value = wksht1.Range("I" & Index).Value
        outputWksht.Range("G" & rownum).Value = wksht1.Range("J" & Index).Value
        outputWksht.Range("H" & rownum).Value = wksht1.Range("K" & Index).Value
        outputWksht.Range("I" & rownum).Value = wksht1.Range("L" & Index).Value
        outputWksht.Range("J" & rownum).Value = wksht1.Range("N" & Index).Value
        outputWksht.Range("K" & rownum).Value = wksht1.Range("O" & Index).Value
        outputWksht.Range("L" & rownum).Value = wksht1.Range("Q" & Index).Value
        outputWksht.Range("M" & rownum).Value = wksht1.Range("R" & Index).Value
        outputWksht.Range("N" & rownum).Value = wksht1.Range("S" & Index).Value
        outputWksht.Range("O" & rownum).Value = wksht1.Range("T" & Index).Value
        outputWksht.Range("P" & rownum).Value = wksht1.Range("U" & Index).Value
        outputWksht.Range("Q" & rownum).Value = wksht1.Range("V" & Index).Value
        outputWksht.Range("R" & rownum).Value = wksht1.Range("W" & Index).Value
        outputWksht.Range("S" & rownum).Value = wksht1.Range("X" & Index).Value
        outputWksht.Range("T" & rownum).Value = wksht1.Range("Y" & Index).Value
        outputWksht.Range("U" & rownum).Value = wksht1.Range("AB" & Index).Value
        outputWksht.Range("V" & rownum).Value = wksht1.Range("AC" & Index).Value
        outputWksht.Range("W" & rownum).Value = wksht1.Range("AE" & Index).Value
        outputWksht.Range("X" & rownum).Value = wksht1.Range("AF" & Index).Value
        outputWksht.Range("Y" & rownum).Value = wksht1.Range("AH" & Index).Value
        outputWksht.Range("Z" & rownum).Value = wksht1.Range("AI" & Index).Value
        outputWksht.Range("AA" & rownum).Value = wksht1.Range("AK" & Index).Value
        outputWksht.Range("AB" & rownum).Value = wksht1.Range("AL" & Index).Value
        outputWksht.Range("AC" & rownum).Value = wksht1.Range("AN" & Index).Value
        outputWksht.Range("AD" & rownum).Value = wksht1.Range("AO" & Index).Value
        outputWksht.Range("AE" & rownum).Value = wksht1.Range("AP" & Index).Value
        outputWksht.Range("AF" & rownum).Value = wksht1.Range("AQ" & Index).Value
        outputWksht.Range("AG" & rownum).Value = wksht1.Range("AW" & Index).Value
        outputWksht.Range("AH" & rownum).Value = wksht1.Range("AX" & Index).Value
        outputWksht.Range("AI" & rownum).Value = wksht1.Range("AY" & Index).Value
        outputWksht.Range("AJ" & rownum).Value = wksht1.Range("BA" & Index).Value
        outputWksht.Range("AK" & rownum).Value = wksht1.Range("BC" & Index).Value
        outputWksht.Range("AL" & rownum).Value = wksht1.Range("AD" & Index).Value
        outputWksht.Range("AM" & rownum).Value = wksht1.Range("BE" & Index).Value
       ' outputWksht.Range("AN" & rownum).Value = wksht1.Range("BF" & Index).Value
        outputWksht.Range("AO" & rownum).Value = wksht1.Range("BG" & Index).Value
        outputWksht.Range("AP" & rownum).Value = wksht1.Range("BR" & Index).Value
        outputWksht.Range("AQ" & rownum).Value = wksht1.Range("BS" & Index).Value
        outputWksht.Range("AR" & rownum).Value = wksht1.Range("BY" & Index).Value
        outputWksht.Range("AS" & rownum).Value = wksht1.Range("CG" & Index).Value
        outputWksht.Range("AT" & rownum).Value
        outputWksht.Range("AU" & rownum).Value = wksht1.Range("CH" & Index).Value
        outputWksht.Range("AV" & rownum).Value = wksht1.Range("CI" & Index).Value


    Dim varcluster As Variant
    Dim clusterRng As Range

    On Error Resume Next
        lngLastMappingRow = wksht2.Range("E" & wksht2.Rows.Count).End(xlUp).Row
        Set clusterRng = wksht2.Range("E1:E" & lngLastMappingRow)

        varcluster = outputWksht.Range("BA" & rownum).Value
        varPosition = Application.WorksheetFunction.Match(varcluster, clusterRng, 0)

    If Err = 0 Then
        'from wksht4 = "mapping"
        outputWksht.Range("AW" & rownum).Value = wksht2.Range("A" & varPosition).Value
        outputWksht.Range("AX" & rownum).Value = wksht2.Range("G" & varPosition).Value
        outputWksht.Range("AY" & rownum).Value = wksht2.Range("I" & varPosition).Value
        outputWksht.Range("AZ" & rownum).Value = wksht2.Range("J" & varPosition).Value
        outputWksht.Range("BA" & rownum).Value = wksht2.Range("E" & varPosition).Value
        outputWksht.Range("BB" & rownum).Value = wksht2.Range("K" & varPosition).Value
        outputWksht.Range("BC" & rownum).Value = wksht2.Range("M" & varPosition).Value
        outputWksht.Range("BD" & rownum).Value = wksht2.Range("N" & varPosition).Value
        outputWksht.Range("BE" & rownum).Value = wksht2.Range("O" & varPosition).Value

    End If
    On Error GoTo 0

    rownum = rownum + 3
    Next

    outputWksht.Columns(24).NumberFormat = "0"
    outputWksht.Cells.EntireColumn.Font.Size = 8
    outputWksht.Rows(1).Font.Size = 10
    outputWksht.Cells.EntireColumn.Font.Name = "Calibri"
    outputWksht.Range("A1:BE1").Interior.Color = RGB(127, 247, 121)
    'outputWksht2.Cells.EntireColumn.Font.Name = "Arial Unicode MS"
    outputWksht.Cells.EntireColumn.HorizontalAlignment = xlCenter
    'outputWksht2.Range("I2:L" & outputRow - 1).HorizontalAlignment = xlLeft
    outputWksht.Rows(1).Font.Bold = True
    outputWksht.Rows(1).Font.Bold = True
    outputWksht.Range("A1:BE1" & rownum).Borders.LineStyle = xlContinuous
    outputWksht.Range("A1:BE1" & rownum).Borders.Weight = xlThin
    outputWksht.Cells.EntireColumn.AutoFit

    Application.DisplayAlerts = True

    Application.StatusBar = "Report is being created. Please wait....84% complete"

End Sub

My code get all data the data from the source file i only need the specific data. Any help would be greatly appreciated.

Answer 1

there is a lot of repetition in your code, a couple of well placed arrays will shorten it, between header start and header end can be completely condensed to:

Range("A1:BD1").Formula = "-----"
Range("AS1:AU1").Formula = Array("Date of Data Extraction", "Priority Inspection", "Basis for Priority")

Further down where you loop through the rows and do the formulas, I wanted to do something just as elegant but the problem is your offset jumps around too much to be done mathematically, I came up with using an offset array, I don't have your data so can't test but this should work replacing the whole massive block:

lngLastRow = wksht1.Range("A" & wksht1.Rows.Count).End(xlUp).Row
'Using an offset array as below can either be a value for an offset command or you could use string references to column letters if you find it easier.
MyOffset = Array(2, 2, 2, 3, 3, 3, 3, 3, 3, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10, 10, 10, 16, 16, 16, 17, 18, 18, 18, 18, 18, 29, 29, 33, 40, 40, 39, 39)
RowNum = 2
For Index = 2 To lngLastRow
    For Y = LBound(MyOffset) To UBound(MyOffset)
        outputWksht.Cells(RowNum, Y + 1).Value = wksht1.Cells(Index, RowNum).Offset(0, MyOffset(Y)).Value
    Next
Dim varcluster As Variant

I have left the line above and below so you can see where to replace the code. You will also need to Dim MyOffset as a variant and Y as a long.

Further down there is a section beginning with

If Err = 0 Then
    'from wksht4 = "mapping"

I have not updated this as I thought you may like to have a go at implementing something similar to what I have shown for the above section.

This updates your existing code to be smaller and easier to modify HOWEVER, it doesn't answer your question. To answer that I would simply copy the lot to a new sheet, filter it then delete the rows with a null then remove the filter like this (works perfectly on the example you posted):

Sub DelStuff()
    ActiveSheet.Copy
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$C$8").AutoFilter Field:=3, Criteria1:="="
    ActiveSheet.Range("$A$1:$C$8").Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Selection.AutoFilter
End Sub

Edit:

You new header code can be condensed to this:

outputWksht.Range("A1:BD1").Formula = Array("OrdStatus", "OrdNo", "RefNo", "FixCode", "FixDescription", "FindCode", "FindDescription", _
"FaultCode", "FaultDescription", "SvcType", "OrdCrtDate", "CustAcNo", "CustomrName", "CustClassn", "NetSvcId", "InstStDate", "BillAddress", _
"InstAddress", "ContactName", "ContactNo", "FranArea", "FranDesc", "SimSn", "SimModel", "PhoneSn", "PhoneModel", "ModemSn", "ModemModel", _
"Node3GId", "BtsIdCDMA", "MDF", "CABINET", "CAB_d_st", "CAB_d_pr", "DP", "DP_e_pr", "DP_add", "CAB_add", "Contractor", "Cluster", "Region", _
"DLY_date", "COM_date", "AcvNotes", "Date of Data Extraction", "Priority Inspection", "Basis for Priority", "QA CONTRACTOR", _
"QA Contractor Type", "QA REGION", "QA REGIONAL AREA", "QA COS CLUSTER", "QA COS SUB AREA", "FO TEAM LEADER", "QA Team Leader", "QA Inspector")

Answer 2

If you are using MS Excel for Windows, simply run SQL on the Master workbook using the Jet/ACE SQL Engine which installs on all PCs in .dll files (and the very engine that MS Access is built on). No loop is required as you simply need a WHERE clause on Header3 column.

Below macro connects to Jet/ACE via ADO with either Provider OLEDB or Driver ODBC (commented out) and outputs query results with column names to an existing worksheet called Repair Details. Be sure to fill in actual sheet name, SheetName$, in SQL statement:

Sub RunSQL()
On Error GoTo ErrHandle
    Dim conn As Object, rst As Object
    Dim strConnection As String, strSQL As String
    Dim i As Integer, fld As Object

    Set conn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")

    ' Hard code database location and name
'    strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
'                      & "DBQ=C\Path\To\Source\Workbook.xlsx;"
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                       & "Data Source='C\Path\To\Source\Workbook.xlsx';" _
                       & "Extended Properties=""Excel 8.0;HDR=YES;"";"

    strSQL = " SELECT [SheetName$].[Header1], [SheetName$].[Header2]," _
                & " [SheetName$].[Header3]" _
                & " FROM [SheetName$]" _
                & " WHERE [SheetName$].[Header3] = 1;"

    ' Open the db connection
    conn.Open strConnection
    rst.Open strSQL, conn

    ' column headers
    i = 0
    Worksheets("Results").Range("A1").Activate
    For Each fld In rst.Fields
        ActiveCell.Offset(0, i) = fld.Name
        i = i + 1
    Next fld

    ' data rows
    Worksheets("Repair Details").Range("A2").CopyFromRecordset rst

    rst.Close
    conn.Close

    MsgBox "Successfully ran SQL query!", vbInformation
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " = " & Err.Description, vbCritical
    Exit Sub
End Sub