Copy Paste and Skip

[Naitnoum]

Good day,

I'm currently completing a project for work and I could use some help. I use Excel 2003. I have a few things I want my spreadsheet to do. I have acheived one of these goals but there are others that I have not.

I want my spreadsheet (dubbed wb1) to do the following via a command button:
1. Check if a file exists (dubbed wb2) in a specific directory. If it does not exist, it will create the file and open the file. If it does exist the file will simply open. [achieved]
2. then, the command button will copy the contents of 6 differnt cells that are not in the same row and paste them in the new workbook (wb2) in a single row.
3. at the same time the button will find the next available row in wb2 to paste the contents of the 6 selected cells.

I hope this explanation was good enough. I have reviewd many sources before finally deciding to post my question. I am fairly new to VB so I hope you all can help me.

Thank you

This is what I have so far:

Private Sub CommandButton1_Click()
If Dir("h:\My Documents\Calls " & Format(Date, "yyyy-mm-dd") & ".xls") <> "" Then
    Set wb1 = ActiveWorkbook.ActiveSheet
    Workbooks.Open ("h:\My Documents\Calls " & Format(Date, "yyyy-mm-dd") & ".xls")
    Set wb2 = Workbooks("Calls " & Format(Date, "yyyy-mm-dd") & ".xls").Sheets(1)
        wb1.Cells(6, 3).Copy wb2.Cells(2, 2)
    Workbooks("Calls " & Format(Date, "yyyy-mm-dd") & ".xls").Save
    MsgBox "File Existed. It was updated and saved."
    Else
        Workbooks.Add.SaveAs Filename:="h:\My Documents\Calls " & Format(Date, "yyyy-mm-dd") & ".xls"
        Workbooks.Open ("h:\My Documents\Calls " & Format(Date, "yyyy-mm-dd") & ".xls")
        Set wb1 = Workbooks("Book1.xls").Sheets("Main Page")
        Set wb2 = Workbooks("Calls " & Format(Date, "yyyy-mm-dd") & ".xls").Sheets(1)
        wb1.Cells(6, 3).Copy wb2.Cells(2, 2)
        Workbooks("Calls " & Format(Date, "yyyy-mm-dd") & ".xls").Save
        MsgBox "File didn't exist. It was created, updated and saved."
End If
End Sub

 

[Ralajer]

Welcome to the board Naitnoum,

I re-wrote your code in trying to get it to work. There were a few parts I was not sure I understood your intent, so I went with:
• For both cases (file existing and not existing) the same sheet would be copied from. That being the active sheet with the command button. Let me know if that was a false assumption.
• The range to copy was not specified as 6 cells but as only 1. I just made it A2:A7 as an example. Just change it to suit. May need further code if the cells are not continuous.
• I also added a test to check if the workbook was already open. Using the open one if it was.

Private Sub CommandButton1_Click()

    Dim wbToOpen As Workbook
    Dim wbSource As Workbook
    Dim copyRng As Range
    Dim pasteRng As Range
    Dim wbToOpenPath As String
    Dim wbToOpenName As String
    Dim wbToOpenFullName As String
    
    '// Build Full name of file to open
    wbToOpenPath = "D:\Test\"
    wbToOpenName = "Calls " & Format(Date, "yyyy-mm-dd") & ".xls"
    wbToOpenFullName = wbToOpenPath & wbToOpenName
    
    '// Set the workbook to active workbook
    Set wbSource = ActiveWorkbook
    
    '// Workbook to open exists
    If Dir(wbToOpenFullName) <> "" Then
    
        '// Check if workbook is currently open
        On Error Resume Next
        Set wbToOpen = Workbooks(wbToOpenName)
        On Error GoTo 0
        
        '// If it is not then open it
        If wbToOpen Is Nothing Then
            Set wbToOpen = Workbooks.Open(Filename:=wbToOpenFullName)
        End If
    
    '// Workbook to open does not exist
    Else
        '// Create and set new workbook to variable
        Set wbToOpen = Workbooks.Add
        '// Save Workbook to path and name
        wbToOpen.SaveAs Filename:=wbToOpenFullName, FileFormat:=xlExcel8
    End If
    
    '// !!! • Range was not specified in original code as 6 cells
    '// !!!    but rather 1 cell being Cells(3, 6) which is cell F3
    
    '// Setting the copy range
    '//     !!! A2 thru A7 for to test of transpose
    Set copyRng = wbSource.ActiveSheet.Range("A2:A7")
    '// Setting Base Paste range as Cell B2 = cells(2, 2)
    Set pasteRng = wbToOpen.Sheets(1).Range("B2")
    
    '// Copy range in source workbook
    copyRng.Copy
    '// Paste copy ranged transposed in the opened workbook
    pasteRng.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
                            SkipBlanks:=False, Transpose:=True
                                
    wbToOpen.Save
End Sub

Let me know if you have question or if I missed your intent.

 

[Naitnoum]

Thanks! Ill try it monday and let you know. thank you for responding!

 

[Ralajer]

There a little thing that I changed to test on my machine and forgot to change in the code I posted. The path to the workbook is D:\Test\ instead of h:\My Documents. Thought I would mention it as it is something that one could miss.

 

[Ralajer]

Realized I missed item 3 in your list. Revised code below.

Private Sub CommandButton1_Click()
'// ———————————————————————————————————————————————————————————————————————————
    Dim wbToOpen As Workbook            '// Workbook to open and paste into
    Dim copyRng As Range                '// Range to be copied this workbook
    Dim pasteRng As Range               '// Base cell to paste to
    Dim wbToOpenPath As String          '// Path - file to Open/Create
    Dim wbToOpenName As String          '// Filename - file to Open/Create
    Dim wbToOpenFullName As String      '// Path+Filename - file to Open/Create
    Dim firstFreeRow As Long            '// First Free row in paste range
    
    '// Build Full name of file to open
    wbToOpenPath = "h:\My Documents\"
    wbToOpenName = "Calls " & Format(Date, "yyyy-mm-dd") & ".xls"
    wbToOpenFullName = wbToOpenPath & wbToOpenName
    
    '// !!! • Range was not specified in original code as 6 cells
    '// !!!    but rather 1 cell being Cells(3, 6) which is cell F3
        '// Setting the copy range
    '//     !!! A2 thru A7 for to test of transpose
    Set copyRng = Me.Range("A2:A7")
    
    '// Workbook to open exists
    If Dir(wbToOpenFullName) <> "" Then
        '// Check if workbook is currently open
        On Error Resume Next
        Set wbToOpen = Nothing
        Set wbToOpen = Workbooks(wbToOpenName)
        On Error GoTo 0
        
        '// If it is not then open it
        If wbToOpen Is Nothing Then
            Set wbToOpen = Workbooks.Open(Filename:=wbToOpenFullName)
        End If
    '// Workbook to open does not exist
    Else
        '// Create and set new workbook to variable
        Set wbToOpen = Workbooks.Add
        '// Save Workbook to path and name
        wbToOpen.SaveAs Filename:=wbToOpenFullName, FileFormat:=xlExcel8
    End If
    '// Determination and setting of paste range
    With wbToOpen.Sheets(1)
        '// Setting Base Paste range as Cell B2 = cells(2, 2)
        Set pasteRng = .Range("B2")
        '// Find first free/unused row in the output column
        firstFreeRow = .Cells(.Rows.Count, pasteRng.Column).End(xlUp).Row + 1
        '// if the first free row is greater then the base row reset
        '//  paste range to the new row otherwise leave it as default
        If firstFreeRow > pasteRng.Row Then
            Set pasteRng = .Cells(firstFreeRow, pasteRng.Column)
        End If
    End With
    
    '// Copy range in source workbook
    copyRng.Copy
    '// Paste copy ranged transposed in the opened workbook
    pasteRng.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
                            SkipBlanks:=False, Transpose:=True
                            
    wbToOpen.Save
End Sub

 

[Naitnoum]

Hi Ralajer,

Thanks for the help. I had an issue with the save as section when the workbook did not already exist but I fixed that.

I may not have communicated what I wanted my spreadsheet to do very well. The first is that I want to be able to take the value of six different cells and paste them in a row, I'm not sure how easy this is. I want to take the values of these cells: C4, C6, C8, F4, F6, F8 and a range of cells C10:M15 and copy/paste them into a single row in the new workbook. The values in these cells change based on the user. The button should add the values of these six cells to the next available row everytime the button is clicked.

I have tried to select multiple cells under one variable and then having that variable pasted into a row, but that never worked.

I really appreciate the help.

 

[Ralajer]

What order do you want them output on the row.
ROW: C4, C6, C8, F4, F6, F8, C10-C15, D10-D15, ... M10-M15
or
ROW: C4, C6, C8, F4, F6, F8, C10-M10, C11-M11, ... C15-M15
or
Some other order.

 

[Naitnoum]

I'd like to have it in horizontal order, so option 2, please and thank you!

 

[Ralajer]

Try this:

Private Sub CommandButton1_Click()
'// ———————————————————————————————————————————————————————————————————————————
    Dim wbToOpen As Workbook            '// Workbook to open and paste into
    Dim copyRng As Range                '// Range to be copied this workbook
    Dim cell As Range
    Dim pasteRng As Range               '// Base cell to paste to
    Dim wbToOpenPath As String          '// Path - file to Open/Create
    Dim wbToOpenName As String          '// Filename - file to Open/Create
    Dim wbToOpenFullName As String      '// Path+Filename - file to Open/Create
    Dim firstFreeRow As Long            '// First Free row in paste range
    Dim outColumn As Integer
    '// Build Full name of file to open
    wbToOpenPath = "h:\My Documents\"
    wbToOpenPath = "D:\Test\"
    wbToOpenName = "Calls " & Format(Date, "yyyy-mm-dd") & ".xls"
    wbToOpenFullName = wbToOpenPath & wbToOpenName
    
    '// Range to copy
    Set copyRng = Me.Range("C4, C6, C8, F4, F6, F8, C10:M15")

    '// Workbook to open exists
    If Dir(wbToOpenFullName) <> "" Then
        '// Check if workbook is currently open
        On Error Resume Next
        Set wbToOpen = Nothing
        Set wbToOpen = Workbooks(wbToOpenName)
        On Error GoTo 0
        
        '// If it is not then open it
        If wbToOpen Is Nothing Then
            Set wbToOpen = Workbooks.Open(Filename:=wbToOpenFullName)
        End If
    '// Workbook to open does not exist
    Else
        '// Create and set new workbook to variable
        Set wbToOpen = Workbooks.Add
        '// Save Workbook to path and name
        wbToOpen.SaveAs Filename:=wbToOpenFullName, FileFormat:=xlExcel8
    End If
    '// Determination and setting of paste range
    With wbToOpen.Sheets(1)
        '// Setting Base Paste range as Cell B2 = cells(2, 2)
        Set pasteRng = .Range("B2")
        '// Find first free/unused row in the output column
        firstFreeRow = .Cells(.Rows.Count, pasteRng.Column).End(xlUp).Row + 1
        '// if the first free row is greater then the base row reset
        '//  paste range to the new row otherwise leave it as default
        If firstFreeRow > pasteRng.Row Then
            Set pasteRng = .Cells(firstFreeRow, pasteRng.Column)
        End If

        outColumn = 0
        '// Loop Throug and output
        For Each cell In copyRng
            cell.Copy .Cells(pasteRng.Row, pasteRng.Column + outColumn)
            outColumn = outColumn + 1
        Next cell
    End With
      
    wbToOpen.Save
End Sub

 

[Naitnoum]

That seems like it might work. However, Im getting run-time erroe 1004 at the following line:

wbToOpen.SaveAs Filename:=wbToOpenFullName, FileFormat:=xlExcel8

I tried changing it as I had done earlier to simply:

wbTOOpen.SaveAS Filename:="h:\My Documents\Calls " & Format(Date,"yyyy-mm-dd") & ".xls", FileFormat:=xlExcel8

but that didnt work this time.