Results 1 to 2 of 2

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

Threaded View

  1. #1
    Registered User
    Join Date
    02-11-2013
    Location
    eugene, or
    MS-Off Ver
    Excel 2011
    Posts
    74

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

    Hey guys. I have a code that is working perfectly, thanks in a large part to folks here, however, I don't completely understand how every aspect of it works, which is giving me trouble customizing it a little further. I have attached the two files I am working with and below is the code that is stored in my personal file to run as a macro. To give a basic idea of what the code does, it takes invoice numbers from the two files and compares them to each other, if the invoice number exists on both documents, it copies additional information from both. One contains hours worked on a job, and one contains the total cost of the job. This information is created in a new workbook with a calculation for the cost per hour and 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 as well and paste it in the 5th column of the new worksheet. From there I want it to average out the cost per hour, per bidder and display that information to the right of the of the spreadsheet, a few columns over from the information, somewhere near the top. 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!

    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))"
    
    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
    
    '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
    Attached Files Attached Files
    Last edited by chouston; 03-13-2013 at 01:30 PM.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1