Exporting

right now this code exports to another sheet, and only exports the active cell. I want to export to a new spreadsheet with a new name, and a given area instead of just the active cell.

Sub ClickAdd()

 Dim rngAvailable As Range, rngCell As Range, bolSuccess As Boolean
        
    Set rngAvailable = ThisWorkbook.Worksheets("Sheet1").Range("B18:B40") 'Range Of Cells'
        
    For Each rngCell In rngAvailable
        If rngCell.Value = vbNullString Then
            rngCell.Value = ActiveCell.Value
            bolSuccess = True
            Exit For
        End If
    Next
    
    If Not bolSuccess Then
        MsgBox "Ran outta spaces...", 0, ""
    End If
    
    End Sub

Is it possible to have the new spreadsheet name preset in the code? the space i am looking to export is A4:C34, F4:F34, I4:Q34. I would also like to know if only the data that gets exported, gets exported if a "y" vs "n" is in place in fields F4:F34?

Its a bit hard to decypher what you are asking for, but to me it seems like you want to copy certain cells in a row if the value in column F of that row is y. If that is true, this should do it for you:

Public Sub jabryantiii()

Sheets("Sheet1").Copy After:=Sheets("Sheet1")
ActiveSheet.Name = "NewSheetName" 'Your wanted sheet name here.
For i = 4 To 34
    If Sheets("Sheet1").Cells(i, 6).Value = "y" Then
        For j = 1 To 3
            ActiveSheet.Cells(i, j).Value = Sheets("Sheet1").Cells(i, j).Value
        Next j
        ActiveSheet.Cells(i, 6).Value = Sheets("Sheet1").Cells(i, 6).Value
        For k = 9 To 17
            ActiveSheet.Cells(i, k).Value = Sheets("Sheet1").Cells(i, k).Value
        Next k
    End If
Next i

End Sub

If not, could you try explaining it again in some other way?

the end result is to have a new sheet, outside of this workbook, created for each month and each sales person, from the data with the given cell range.

Hmm, I can't understand why that error would appear if you don't have a sheet with that name already in that workbook. Can you try changing the name in the code and running again?

Ok, it is easy to change the code to add a new blank sheet instead of copying the whole sheet:

Public Sub jabryantiii()

Sheets.Add After:=Sheets("Sheet1")
ActiveSheet.Name = "NewSheetName" 'Your wanted sheet name here.
For i = 4 To 34
    If Sheets("Sheet1").Cells(i, 6).Value = "y" Then
        For j = 1 To 3
            ActiveSheet.Cells(i, j).Value = Sheets("Sheet1").Cells(i, j).Value
        Next j
        ActiveSheet.Cells(i, 6).Value = Sheets("Sheet1").Cells(i, 6).Value
        For k = 9 To 17
            ActiveSheet.Cells(i, k).Value = Sheets("Sheet1").Cells(i, k).Value
        Next k
    End If
Next i

End Sub

However, I think we need to modify that sinse you will want to run it for each employee in that particular workbook.
Are all the sheet in the workbook one of the employee sheets, or do you have any summary or other info sheets?
On what cell is the name of the employee for each sheet? On what cell is the month and year for that set of data?

try this:

Private Sub Save()
    ActiveSheet.Copy
    With ActiveSheet.UsedRange
        .Copy
        .PasteSpecial xlValues
        .PasteSpecial xlFormats
    End With
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs ActiveSheet.Name & Format(Date, "yyyymmdd")
End Sub

that works for what exactly? The thing i am trying to accomplish would take data from a specific cell range put it into a new sheet seperate from the current workbook.

Currently the code i am trying to get to work is either creating a blank new sheet or copying the active sheet to another sheet with a new name. Both are great attempts but niether are hitting th mark yet.

I know how to transfer data from a single cell using a button, I am just hoping to get a specific range instead and into a new sheet outside of the active workbook.


I see what it does now...thanks. But I want to be able to run it off a button and only for specific cell ranges. That copies the entire page outside of the workbook...which is nice.

try this:

select a range in your workbook and it will copy that range to another workbook..

is this it?

Sub Save()
    Dim myRange As String
    myRange = Selection.Address
    
    With Selection
        .Copy
        .PasteSpecial xlValues
        .PasteSpecial xlFormats
    End With
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs ActiveSheet.Name & Format(Date, "yyyymmdd")
End Sub

The reason my code was creating a blank sheet was because in your sample workbook, you have capital Y and N in column F. Your instructions earlier said uncapitalized y and n. If you change the "y" to "Y" in the code, it will tranfer the data.

Simple, just delete the page inside the workbook after you have copied it out of the workbook.

Sheets("SheetName").Delete

To turn the warning off, use:

Application.DisplayAlerts = False

What specifically was the probelm with deleting the copy made inside the workbook?

so before you run the delete code, go back to the original workbook:

Workbooks("YourWorkbook").Activate

ok...I need a cleaner way for this to work.
I have an idea but i am not sure how to implement it.
this code creates the sheet in it own workbook but not the range i want or with the delimiter based on the "y" vs "n". (i have tried the active cell highlighting and still end up with a reprduction of the entire page)

Sub Save()
    Dim myRange As String
    myRange = Selection.Address
    
    With Selection
        .Copy
        .PasteSpecial xlValues
        .PasteSpecial xlFormats
    End With
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs ActiveSheet.Name & Format(Date, "yyyymmdd")
End Sub

this code creates the data i want in the same workbook and the range i am looking for based on the "y" vs "n"

Public Sub jabryantiii()

Sheets.Add After:=Sheets("Sheet1")
ActiveSheet.Name = "NewSheetName" 'Your wanted sheet name here.
For i = 4 To 34
    If Sheets("Sheet1").Cells(i, 6).Value = "y" Then
        For j = 1 To 3
            ActiveSheet.Cells(i, j).Value = Sheets("Sheet1").Cells(i, j).Value
        Next j
        ActiveSheet.Cells(i, 6).Value = Sheets("Sheet1").Cells(i, 6).Value
        For k = 9 To 17
            ActiveSheet.Cells(i, k).Value = Sheets("Sheet1").Cells(i, k).Value
        Next k
    End If
Next i

End Sub

So some how i need to combine the above code(s) into one to not only grab just the data i want based on the "y" vs "n" but i also need to to be created outside of the original workbook.

is it possible to set the created data to a specific cell on the new page, so that when i code the button to Feb, Mar, Apr, Jun....that they are all displayed on the top of the workbook?

Public Sub jabryantiii()

Dim CurrentWB As String
Dim NewWB As String

CurrentWB = ActiveWorkbook.Name
Sheets.Add After:=Sheets("Sheet1")
ActiveSheet.Name = "NewSheetName" 'Your wanted sheet name here.
For i = 4 To 34
    If Sheets("Sheet1").Cells(i, 6).Value = "y" Then
        For j = 1 To 3
            ActiveSheet.Cells(i, j).Value = Sheets("Sheet1").Cells(i, j).Value
        Next j
        ActiveSheet.Cells(i, 6).Value = Sheets("Sheet1").Cells(i, 6).Value
        For k = 9 To 17
            ActiveSheet.Cells(i, k).Value = Sheets("Sheet1").Cells(i, k).Value
        Next k
    End If
Next i
ActiveSheet.Copy
NewWB = ActiveWorkbook.Name

Workbooks(CurrentWB).Activate
Sheets("NewSheetName").Delete

End Sub

To have this happen in realtime, the macro can watch column F for "y" entries being entered, and the macro can instantly copy the item to the appropriate sheets.

This macro will create the January/February/etc sheets if they do not already exist, so you don't have to worry about that either.

Lastly, the macro will check to make sure the item it is about to transfer has not already been transferred. It does this by checking the value in column B, the Account/Job Name field. If it is found, a message will pop to indicate so.

1) Right-click on the sheet-tab John Smith and select VIEW CODE
2) Remove the code in there currently
3) Paste in this new sheet event macro

Option Explicit         'code checking on
Option Compare Text     'non-case-sensitive code

Private Sub Worksheet_Change(ByVal Target As Range)
'JBeaucaire  1/15/2010
'Transfer items marked "y" in column F to monthly sheets
'verify items have not been transferred previously

Dim cell As Range, rFind As Range, mSh As Worksheet
Dim cName As String, Val As String, NR As Long, r As Long

For Each cell In Target
    If cell.Column = 6 And cell.Value = "y" Then
        'Create sheet if necessary, get account name and row number
            r = cell.Row
            cName = Range("B" & r).Text
            Val = Cells(r, "A").End(xlUp).Text
            If Not Evaluate("ISREF(" & Val & "!A1)") Then
                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Val
                Me.Activate
                Set mSh = Sheets(Val)
                Range("A4:Q4").Copy
                mSh.Range("A1").PasteSpecial (xlPasteAll)
                mSh.Range("A1").PasteSpecial (xlPasteColumnWidths)
                mSh.Range("D:E,G:H").EntireColumn.Delete xlShiftToLeft
            Else
                Set mSh = Sheets(Val)
            End If
        
        'verify ACCOUNT/JOB NAME does not already exist on that sheet
        On Error Resume Next
        Set rFind = mSh.Range("B:B").Find(cName, After:=[B1], LookIn:=xlValues, LookAt:=xlWhole)
        On Error GoTo 0

        If rFind Is Nothing Then
            NR = mSh.Range("B" & Rows.Count).End(xlUp).Row + 1
        Else
            MsgBox "Item has been transferred already"
            Exit Sub
        End If
        
        Set rFind = Range("A" & r & ":C" & r & ",F" & r & ",I" & r & ":Q" & r)
        rFind.Copy mSh.Range("A" & NR)

    End If
Next cell

Beep
End Sub

6) Close the editor and save your sheet
7) fill in some rows and add "y" or "Y" to column F, they will transfer on their own. You will hear a "beep" letting you know it happened.
8) You can delete the button

NOTE: This macro will also work regardless of the capitalization of the y/Y, both are fine.

I wouldn't hard code it that way. You're just asking for headaches tweaking the code.

Let's just add the name into the empty column A for each pasted row, then sort all the data. Doing this each time we add something will keep each person's items together without having to maintain separate "sections".

Option Explicit         'code checking on
Option Compare Text     'non-case-sensitive code

Private Sub Worksheet_Change(ByVal Target As Range)
'JBeaucaire  1/15/2010
'Transfer items marked "y" in column F to monthly sheets
'verify items have not been transferred previously

Dim cell As Range, rFind As Range, mSh As Worksheet
Dim cName As String, Val As String, NR As Long, r As Long

For Each cell In Target
    If cell.Column = 6 And cell.Value = "y" Then
        'Create sheet if necessary, get account name and row number
            r = cell.Row
            cName = Range("B" & r).Text
            Val = Cells(r, "A").End(xlUp).Text
            If Not Evaluate("ISREF(" & Val & "!A1)") Then
                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Val
                Me.Activate
                Set mSh = Sheets(Val)
                Range("A4:Q4").Copy
                mSh.Range("A1").PasteSpecial (xlPasteAll)
                mSh.Range("A1").PasteSpecial (xlPasteColumnWidths)
                mSh.Range("D:E,G:H").EntireColumn.Delete xlShiftToLeft
            Else
                Set mSh = Sheets(Val)
            End If
        
        'verify ACCOUNT/JOB NAME does not already exist on that sheet
        On Error Resume Next
        Set rFind = mSh.Range("B:B").Find(cName, After:=[B1], LookIn:=xlValues, LookAt:=xlWhole)
        On Error GoTo 0

        If rFind Is Nothing Then
            NR = mSh.Range("B" & Rows.Count).End(xlUp).Row + 1
        Else
            MsgBox "Item has been transferred already"
            Exit Sub
        End If
        
        Set rFind = Range("A" & r & ":C" & r & ",F" & r & ",I" & r & ":Q" & r)
        rFind.Copy mSh.Range("A" & NR)
        mSh.Range("A" & NR) = Me.Name
    Else
        Exit Sub
    End If
Next cell

With mSh.Range("A1").CurrentRegion
    .Sort Key1:=mSh.Range("A2"), Order1:=xlAscending, Key2:=mSh.Range("B2"), _
        Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
    .Borders.Weight = xlThin
End With

Beep
End Sub

Post up your workbook with the macro already installed.

BTW, if this is supposed to occur in every worksheet, we can restructure this into a single workbook-event macro in ThisWorkbook so you won't have to maintain a bunch of copies of the same macro.

Try zipping the file first.

Try zipping the file first. There's a 1mb max on file sizes, I think.

1) Don't merge cells. There's no reason to merge columns S:Z to make wide cells when simply widening column S does the same thing. Merging cells on sheets you want to run macros on just makes more unnecesssary work.

I unmerged them and widened column S.

2) The unused cells in column A have to be empty for this to work properly. Right now, there is a hidden character in cell A5 that is messing it up. I'm sure it was accidental, but be aware.

3) Here's a regular macro version, goes in a standard module:

Option Explicit
Option Compare Text

Sub Transfer()
'JBeaucaire  1/19/2010
'Transfer items marked "y" in column F to monthly sheets
'verify items have not been transferred previously

Dim RNG As Range, cell As Range, rFind As Range, mSh As Worksheet, dSh As Worksheet
Dim cName As String, Val As String, NR As Long, r As Long

Set RNG = ActiveSheet.Range("F:F").SpecialCells(xlCellTypeConstants, 2)
Set dSh = ActiveSheet

For Each cell In RNG
    If cell = "y" Then
        'Create sheet if necessary, get account name and row number
            r = cell.Row
            cName = Range("B" & r).Text
            Val = Cells(r, "A").End(xlUp).Text
            On Error Resume Next
            If Not Evaluate("ISREF(" & Val & "!A1)") Then
                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Val
                dSh.Activate
                Set mSh = Sheets(Val)
                Range("A4:Q4").Copy
                mSh.Range("A1").PasteSpecial (xlPasteAll)
                mSh.Range("A1").PasteSpecial (xlPasteColumnWidths)
                mSh.Range("D:E,G:H").EntireColumn.Delete xlShiftToLeft
            Else
                Set mSh = Sheets(Val)
            End If
        
        'verify ACCOUNT/JOB NAME does not already exist on that sheet
        Set rFind = mSh.Range("B:B").Find(cName, After:=[B1], LookIn:=xlValues, LookAt:=xlWhole)

        If rFind Is Nothing Then
            NR = mSh.Range("B" & Rows.Count).End(xlUp).Row + 1
        Else
            GoTo Next1
        End If
        
        Set rFind = Range("A" & r & ":C" & r & ",F" & r & ",I" & r & ":Q" & r)
        rFind.Copy mSh.Range("A" & NR)
        mSh.Range("A" & NR) = dSh.Name
    End If
Next1:
Next cell

With mSh.Range("A1").CurrentRegion
    .Sort Key1:=mSh.Range("A2"), Order1:=xlAscending, Key2:=mSh.Range("B2"), _
        Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
    .Borders.Weight = xlThin
End With

Beep
End Sub

4) Open the FORMS toolbar and add a form button, assign the macro "Transfer" to it. Use the button to initiate the transfers.

If that takes care of your need, be sure to EDIT your original post, click Go Advanced and mark the PREFIX box [SOLVED].


(Also, use the blue "scales" icon in our posts to leave Reputation Feedback, it is appreciated. It is found across from the "time" in each of our posts.)

Add this one line:

                mSh.Range("D:E,G:H").EntireColumn.Delete xlShiftToLeft
                mSh.Range("A1") = mSh.Name
            Else
                Set mSh = Sheets(Val)
            End If