Copy cell data if other variables are true, paste into new worksheet

[chouston85]

Hey guys. I have a code that is working perfectly, thanks in a large part to folks on this forum and others, however, I don't completely understand how every aspect of it works, which is giving me trouble customizing it a little further. To give a basic idea of what the code does, it takes invoice numbers from two files, QB Output and Timeclock Output and compares them to each other, if the invoice number exists on both documents, it copies the total cost of the job from the QB Output file and pastes it into column H of Timeclock Output. This information is copies in a new workbook along with the invoice number and total hours worked. a calculation for the cost per hour is added and the file is saved wherever the user wants, a few clean up tasks run and it's done. What I am trying to add, is associated with each of these jobs is a REP code to tell us who bid the work. I'm trying to figure out how to make it copy this information at the same time as the total cost and paste that into column I in the same way it does the totals. From there I Think I can figure out how to make it do what I want. Any help would be REALLY appreciated, this project is so close to done. I'm going to keep playing with it and I'll post any progress here! Thanks again! Not that it matters, but this all runs from a macro in the personal workbook, just fyi.

This is the piece that grabs the total cost, and is what I think needs to be modified...

[/COLOR]Range(Cells(4, 8), Cells(Bot, 8)).FormulaR1C1 = "=IF(SUMIF('[QB Output.xlsx]Sheet1'!C4,RC3,'[QB Output.xlsx]Sheet1'!C6)=0,"""",SUMIF('[QB Output.xlsx]Sheet1'!C4,RC3,'[QB Output.xlsx]Sheet1'!C6))"[COLOR=#333333]

This is my full code:

[/COLOR]Sub CreateWorkbooksV2()

Application.ScreenUpdating = False


Workbooks("Timeclock Output.xlsx").Activate


Dim timecodeSheet As Worksheet
Set timecodeSheet = Sheets("Sheet1")


Dim Bot As Integer ' May have to change this if the last row gets too big
Bot = timecodeSheet.Cells(Rows.Count, 1).End(xlUp).Row


'Add the formulas
Range(Cells(4, 8), Cells(Bot, 8)).FormulaR1C1 = "=IF(SUMIF('[QB Output.xlsx]Sheet1'!C4,RC3,'[QB Output.xlsx]Sheet1'!C6)=0,"""",SUMIF('[QB Output.xlsx]Sheet1'!C4,RC3,'[QB Output.xlsx]Sheet1'!C6))"


'Range(Cells(4, 9), Cells(Bot, 9)).FormulaR1C1 = "=IF('[QB Output.xlsx]Sheet1'!C4,RC3,'[QB Output.xlsx]Sheet1'!C8)=vbNullString,"""",IF('[QB Output.xlsx]Sheet1'!C4,RC3,'[QB Output.xlsx]Sheet1'!C8)"


Dim newSheet As Worksheet
Sheets.Add After:=Sheets(Sheets.Count)
Set newSheet = ActiveSheet


timecodeSheet.Range("C:C").Copy Destination:=newSheet.Cells(1, 1) ' Done twice because of merged cells
timecodeSheet.Range("G:G").Copy Destination:=newSheet.Cells(1, 2)
timecodeSheet.Range("H:H").Copy Destination:=newSheet.Cells(1, 3) ' Done a third time for the new formula columns


For i = Bot To 2 Step -1 ' Start from the last row and go up
    If Cells(i, 1) = "?" Or Cells(i, 1) = vbNullString Or Cells(i, 1) = "Level 3" Or Cells(i, 1) = "" Or UCase(Trim(Right(Cells(i, 1), 5))) = "TOTAL" Then Rows(i).Delete Shift:=xlUp ' If the first cell of row is ?, empty, or Level 3 delete the row
Next




'NAME THE NEW SHEET TO BE SAVED
ActiveSheet.Name = "Summary"


'SET THE TITLES
Range("A1") = "Invoice"
Range("A1").Font.Bold = True
Range("A1").Font.Color = vbRed
Range("A1").Select
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = xlAutomatic
    .TintAndShade = 0
    .Weight = xlMedium
End With


Range("B1") = "Hours"
Range("B1").Font.Bold = True
Range("B1").Font.Color = vbRed
Range("B1").Select
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = xlAutomatic
    .TintAndShade = 0
    .Weight = xlMedium
End With


Range("C1") = "Cost"
Range("C1").Font.Bold = True
Range("C1").Font.Color = vbRed
Range("C1").Select
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = xlAutomatic
    .TintAndShade = 0
    .Weight = xlMedium
End With


Range("D1") = "$/HR"
Range("D1").Font.Bold = True
Range("D1").Font.Color = vbRed
Range("D1").Select
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = xlAutomatic
    .TintAndShade = 0
    .Weight = xlMedium
End With


Range("E1") = "Bidder"
Range("E1").Font.Bold = True
Range("E1").Font.Color = vbRed
Range("E1").Select
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = xlAutomatic
    .TintAndShade = 0
    .Weight = xlMedium
End With
Columns("E:E").Select
Selection.HorizontalAlignment = xlRight
Range("E1").Select
Selection.HorizontalAlignment = xlLeft


'TURN FORMULAS INTO VALUES
Columns("C:C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


'PASTE COST PER HOUR FORMULA
Dim lrow As Long
Dim r As Range




lrow = Cells(Rows.Count, 3).End(xlUp).Row + 1




For Each r In Range("C2:C" & lrow)


    If r.Value <> vbNullString Then
        r.Offset(0, 1).FormulaR1C1 = "=IF(RC[-2]=0,"""",ROUND(RC[-1]/(RC[-2]*24),2))"
    End If


Next


'ADJUST COLUMN WIDTH


Columns("A:A").ColumnWidth = 12.7


'CREATE NEW WORK BOOK/FILE SAVE
     
     
Sheets("Summary").Copy
Dim wb As Workbook
Set wb = ActiveWorkbook
    
Do
    fName = Application.GetSaveAsFilename
    Loop Until fName <> False
wb.SaveAs Filename:=fName & "xlsx", FileFormat:=xlWorkbookDefault
    


'DELTE UNNECESARY DATA




Application.DisplayAlerts = False
Workbooks("Timeclock Output.xlsx").Activate
Sheets("Summary").Delete
Columns("H:H").Select
Selection.ClearContents




'CLOSE WORKBOOKS
ActiveWorkbook.Close False
Workbooks("QB Output.xlsx").Activate
ActiveWorkbook.Close False
Application.DisplayAlerts = True


Application.ScreenUpdating = True


End Sub


[COLOR=#333333]

I can share the workbooks if it's useful, I just don't see a way to upload them.

 

[JMonty]

'Add the formulas
Range(Cells(4, 8), Cells(Bot, 8)).FormulaR1C1 = "=IF(SUMIF('[QB Output.xlsx]Sheet1'!C4,RC3,'[QB Output.xlsx]Sheet1'!C6)=0,"""",SUMIF('[QB Output.xlsx]Sheet1'!C4,RC3,'[QB Output.xlsx]Sheet1'!C6))

The above code means it plugs in the formula from Row 4 to the last row in Column 8 (simply, H4:Hx where x is the last row number).

Now:

timecodeSheet.Range("C:C").Copy Destination:=newSheet.Cells(1, 1) ' Done twice because of merged cellstimecodeSheet.Range("G:G").Copy Destination:=newSheet.Cells(1, 2)
timecodeSheet.Range("H:H").Copy Destination:=newSheet.Cells(1, 3) ' Done a third time for the new formula columns

This part basically reads, "From my current sheet, I copy Column C to the first column of the new sheet I created. I repeat this for Column G and Column H." From what I posted above, column H is the formulas column, correct?

Now, what you need to do is get the column of REP from the original sheet (say, it's column J) and add the following line to the code above:

timecodeSheet.Range("J:J").Copy Destination:=newSheet.Cells(1, 4)

This will copy-paste Column J to the fourth column in the new sheet.

I am too lazy to check the other parts of the code since it's all over the place but I think the above is pretty much enough (unless there are some other parts in the clean up step that deletes all other columns).

We look forward to your response.

 

[chouston85]

Hi JMonty,
Thanks for the response! I will need to copy the rep in the way you described, however, the part I am having trouble with is getting that rep code, which is on the QB file sheet, and associated with an invoice number, copied over to column J of the Timecode File.... I am attaching screenshots of my workbooks to hopefully make this clearer....

 

[JMonty]

Turn this part of the code into a comment by adding ' at the beginning:

For i = Bot To 2 Step -1 ' Start from the last row and go up    If Cells(i, 1) = "?" Or Cells(i, 1) = vbNullString Or Cells(i, 1) = "Level 3" Or Cells(i, 1) = "" Or UCase(Trim(Right(Cells(i, 1), 5))) = "TOTAL" Then Rows(i).Delete Shift:=xlUp ' If the first cell of row is ?, empty, or Level 3 delete the row
Next

Then add this after:

Dim chkCell As Range
Dim tgtBook As Workbook


Set tgtBook = Workbooks("QB Output.xlsx")


For i = Bot To 2 Step -1
    Set chkCell = Cells(i, 1)
    If chkCell = "?" Or _
    chkCell = vbNullString Or _
    chkCell = "Level 3" Or _
    chkCell = "" Or _
    UCase(Trim(Right(chkCell, 5))) = "TOTAL" Then
        Rows(i).Delete Shift:=xlUp
    Else
        Cells(i, 10) = Application.WorksheetFunction.VLookup(chkCell, tgtBook.Range("D:H"), 5, False)
    End If
Next i

I just want to share that the VBA code is all over the place. It can be optimized further and be made easier to customize. Like, for example, instead of using multiple OR conditions in the IF part, you can use CASE instead, etc.

For now, try this one. Basically, it does the same thing as the previous code we turned into a comment. What it does IN ADDITION, is that if the row contains an Invoice Number (not a "?", "Level 3", "TOTAL", or empty), instead of ignoring it in the clean-up phase, it will do a VLOOKUP versus the QB Output workbook and return the rep code from column H.

All else fails, I suggest loading up the files in Google Drive, Dropbox, Mediafire, etc. and I'll devote a little time to improving it. You can delete all the sensitive data if you want, just keep in the important ones.

Thanks and hoping for your response.

 

[chouston85]

I would absolutely love it if you wanted to take the time to do that. I am currently learning <acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-bottom-style: dotted; border-bottom-color: rgb(0, 0, 0); cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">VBA</acronym>the hard way, with a project that I am way under-qualified for. My employer has asked for even more functionality added so that it costs by individual employee in the field as well as by bidder and company. I'm not sure how I'm going to make that part work either, but having the code not so garbled would be an amazing help. I'm not sure where the best place to upload file is, or if emailing them would be easier. Again, thanks, and let me know what works best for you!