Super Macro multiple conditions

DBR138 · Feb 28th 2018

I am trying to automate the creation of a report that I presently make to such a level that I can push it onto the users who are not known for their computer skills. I enjoy macros and VBA but this is a little more ambitious than I have gotten so far. I am attaching a sample file containing the source data and the template it will end up in. What I need to do is for each cell in column C of the Data tab where H is not "QC-Completed" and U is blank the copy S, AD, B, C, E, H, L and paste them into the next unused row on tab Pass On in the order I listed to cut them so S would go to A and AD would go to B and so on.
I am hung up on the multiple conditions and I do have a tendency to over think these things.

Ideally this would fit into the following code that I have already written:

Code

Sub ImportOracleShopFloor()


Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sheet As Worksheet
Dim PasteStart As Range


Sheets("Data").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Sheets("Pass On").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Sheets("Start").Select
   
Set wb1 = ActiveWorkbook
Set PasteStart = [Data!A1]


FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a Report to Parse", _
FileFilter:="Report Files *.xlsx (*.xlsx),")


If FileToOpen = False Then
    MsgBox "No File Specified.", vbExclamation, "ERROR"
    Exit Sub
Else
    Set wb2 = Workbooks.Open(Filename:=FileToOpen)


    For Each Sheet In wb2.Sheets
        With Sheet.UsedRange
            .Copy PasteStart
            Set PasteStart = PasteStart.Offset(.Rows.Count)
        End With
    Next Sheet


End If


    wb2.Close
   
 Sheets("Header  Template").Select
    Rows("1:1").Select
    Selection.Copy
    Sheets("Pass On").Select
    Rows("1:1").Select
    ActiveSheet.Paste
   
   
   
   'New code belongs here
   
   
   
MsgBox "Pass on creation succesful! Please update your comments and submit."
End Sub

Display More

**KjBox** · Feb 28th 2018

Try this, I have tied up your code a bit and added new code to get the required data from the "Data" sheet and add it to the "Pass On" sheet.

Note that there is no need to copy the Pass On headers every time if only the data below the headers is cleared before new data added, the code below does that.

Code

Sub ImportOracleShopFloor()
    Dim wb1 As Workbook, wb2 As Workbook, Sheet As Worksheet
    Dim x, y(), PasteStart As Range, i As Long, ii As Long
    Set wb1 = ActiveWorkbook
    Set PasteStart = Sheets("Data").[a1]


    Application.ScreeUpdating = 0
    Sheets("Data").Cells.Clear
    Sheets("Start").Activate
  
    FileToOpen = Application.GetOpenFilename _
    (Title:="Please choose a Report to Parse", _
    FileFilter:="Report Files *.xlsx (*.xlsx),")


    If FileToOpen = False Then
        MsgBox "No File Specified.", vbExclamation, "ERROR"
        Exit Sub
    Else
        Set wb2 = Workbooks.Open(Filename:=FileToOpen)
        For Each Sheet In wb2.Sheets
            i = Sheet.UsedRange.Rows.Count
            Sheet.UsedRange.Copy PasteStart
            Set PasteStart = PasteStart.Offset(i)
        Next Sheet
    End If
    wb2.Close 0
  
    x = Sheets("Data").Cells(1).CurrentRegion
    For i = 1 To UBound(x, 1)
        If x(i, 8) = "QC-Completed" And x(i, 21) = "" Then
            ii = ii + 1: ReDim Preserve y(1 To 7, 1 To ii)
            y(1, ii) = x(i, 19): y(2, ii) = x(i, 30): y(3, ii) = x(i, 2)
            y(4, ii) = x(i, 3): y(5, ii) = x(i, 5): y(6, ii) = x(i, 8)
            y(7, ii) = x(i, 12)
        End If
    Next
    With Sheets("Pass On")
        .UsedRange.Offset(1).Clear
        .[a2].Resize(ii, 7) = Application.Transpose(y)
        .Activate
    End With
  
    MsgBox "Pass on creation succesful! Please update your comments and submit."
    
End Sub

Display More

Super Macro multiple conditions

Participate now!

Share