I am trying to print several non-contiguous columns on one sheet of paper. I am using the set print area in page layout. However it has created a page break after each column range. I have a macro that allows you to paste a range of data, and then it clears the data and prints the page. So hiding the columns isn't working. Can someone tell me how to print just the columns I need on one piece of paper. Here is the macro where I would like to include the printing code.
Sub cleardatanotformulas()
ActiveWindow.SelectedSheets.PrintOut Copies:=1
On Error Resume Next
Cells.SpecialCells(xlCellTypeConstants).ClearContents
ActiveWorkbook.Close SaveChanges:=False
End Sub
You can create a new page to receive your selected columns for printing Like this code below. Mu non-contiguous columns are in MySourceSheet. You have to copy them in MytargetSheet and print it.
Sub CopyInAdjacentColumnsForPrinting()
Sheets("MySourceSheet").Select
Range("A:A,C:C,E:E").Select 'We select A, C and E columns for example, you can specify your own columns
Range("E1").Activate
Selection.Copy
Sheets("MyTargetSheet").Select ' This sheet is for receiving selected columns in contiguous columns.
Range("A1").Select
ActiveSheet.Paste ' We copied selected columns in this sheet.
Range("A1").Select
End Sub
Hope this can help!
Sorry #Anne B, I cannot add my code in comment bloc, then I add a new answer :)
Based on the fact that you copied your non-contiguous columns in the sheet named MyTargetSeet (in this example).
You can use this.
Sub ZoneImp()
Dim FirstCol As Integer, LastCol As Integer, FirstLin As Integer, FirstLin As Integer
FirstCol = 1
LastCol = 3
FirstLin = 1
LastLin = 6
'Here I create my Area for printing
Sheets("MyTargetSheet").PageSetup.PrintArea = Range(Cells(FirstLin, FirstCol), Cells(LastLin, LastCol)).Address
End Sub
Hope this can help!
Related
Background
I have a workbook with 7 sheets but only 6 with data. All of these 7 sheets have the same structure/headings, it's just that the last sheet (sheet 7) is blank.
I want to write a code that will copy the contents of sheets 1-6 in the range of A2:J15 into the sheet 7 worksheet. I currently have a code that I have been using to test and see if it works but the code I have only copies and pastes from one worksheet only (see below). Any suggestions?
In the below, I have two sheets where I want the data to come from and the destination sheet where I want the data to go:
Sub sbCopyRangeToAnotherSheet()
Sheets("Source1").Range("A1:B10").Copy
Sheets("Source2").Range("A1:B10").Copy
Sheets("Destination").Activate
Range("A1:B10").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Your problem is coming from your attempt to copy two items directly after each other. The second copy call is overwriting the data you copied in the first call.
Sheets("Source1").Range("A1:B10").Copy
Sheets("Destination").Activate
Range("A1:B10").Select
ActiveSheet.Paste
Sheets("Source2").Range("<your new range here>").Copy
Sheets("Destination").Activate
Range("<your new range here>").Select
ActiveSheet.Paste
Application.CutCopyMode = False
The code above should explain what I mean albeit not the most efficient way. A more effective way would be to use:
Sheets("Source1").Range("A1:B10").Copy Destination:=Sheets("Destination").Range("A1:B10")
Sheets("Source2").Range("A1:B10").Copy Destination:=Sheets("Destination").Range("<range>")
As sugguested in the comments:
Sub sbCopyRangeToAnotherSheet()
Sheets("Source1").Range("A1:B10").Copy Sheets("7").Range("A1")
Sheets("Source2").Range("A1:B10").Copy Sheets("7").Range("A1").end(xlDown).offset(1,0)
Sheets("Source3").Range("A1:B10").Copy Sheets("7").Range("A1").end(xlDown).offset(1,0)
Sheets("Source4").Range("A1:B10").Copy Sheets("7").Range("A1").end(xlDown).offset(1,0)
Sheets("Source5").Range("A1:B10").Copy Sheets("7").Range("A1").end(xlDown).offset(1,0)
Sheets("Source6").Range("A1:B10").Copy Sheets("7").Range("A1").end(xlDown).offset(1,0)
End Sub
Assuming that you want to paste the data by rows (and not overwrite it), and your sheets are named Source1 to Source6, then the following should work:
Sub testSO()
For i = 1 To 6
Sheets("Source" & i).Range("A1:B10").Copy Sheets("Destination").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next i
End Sub
Use case: I want to copy data from column A to Column B (where column A, B are arbitrary columns). Once the data is in Column B, I want to remove duplicate entries within column B.
Make a loop that moves data from column A to column B and then removes duplicates for each sheet in a workbook.
`Sub Copy()
For i = 1 To Sheets.Count
Worksheets(i).Range("A1:A100")
Destination:=Worksheets(i).Range("B1")
Next
End Sub
`
For testing I separated the tasks into two different Sub(). Sub Copy() is working and correctly copies my data. Sheet1 is also named "Sheet1" for my specific workbook
`Sub RemoveStuff()
Dim rng As Range
For j = 1 To Sheets.Count
Set rng = Worksheets("Sheet1").Range(Range("B1"),Range("B1").End(xlDown)).Select
rng.RemoveDuplicates Columns:=(1), Header:=xlGuess
Next
End Sub
`
My error seems to be in defining the range correctly. Each sheet will have a different number of entries to remove duplicates from. Sheet1 might have 50 rows and reduce to 6. Sheet2 could have 70 and reduce to 3. Sheet3 could have 20 rows and reduce to 12 uniques. Excel does not let you remove duplicates from range (B:B!)
How can I properly define my range so I can remove duplicates in a loop for a dynamically defined range for each sheet(sheet=tabs in workbook)?
EDIT 2-23-17
New code from Y0wE3K
Sub RemoveStuff()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Columns("P:P").RemoveDuplicates,Columns:=1, Header:=xlYes
Next
End Sub
Still does not work. If I manually select Column P before I run the macro, it works. But it only goes for the one sheet I have selected, it does not seem to execute the loop. Definitely does not automatically do each sheet, or prompt me for each one.
EDIT: 3/4
Make sure that you do not have any protected data, I also experienced issues with pivot tables but I think this may be permissions thank you for help.
Your RemoveStuff subroutine can be rewritten as:
Sub RemoveStuff()
Dim ws As Worksheet
For Each ws In Worksheets ' Use Worksheets instead of Sheets,
' in case there are any Charts
'You can just select the whole column, rather than selecting
'specific rows
ws.Columns("B:B").RemoveDuplicates Columns:=1, Header:=xlGuess
Next
End Sub
Sub RemoveStuff()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Columns("P:P").RemoveDuplicates,Columns:=1, Header:=xlYes
Next
End Sub
This code will work. As a final note, please make sure you have no Protected Data, or pivot tables inside of the sheets you need to run the remove script on. For whatever reason that caused mine to fail, but running my script on the correct sheets that are unprotected worked GREAT.
I am busy creating a production schedule in excel 2010. I have used formulas to give me due dates for each job and a check box for when the job are done. I used the following VB to move the information to sheet 2 when the check box is checked.
Sub MoveData()
If ThisWorkbook.Worksheets(1).Shapes("Check Box 1").OLEFormat.Object.Value = 1 Then
Range("A2:B2:C2:D2:E2:F2:G2:H2:I2:J2:K2:L2:M2").Select
Selection.Cut
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
End If
End Sub
The problem I have now is that it moves the formulas with the details in the cells from sheet 1 to sheet 2. I need the formulas to be locked in sheet 1 and affect new information inserted into the cells.
When the data in the row moves to sheet 2 the row is empty in sheet 1. Is there a way to automatically move all the remaining data up to fill the empty cells
Thanx
Do you just want to copy the values from Worksheets(1) to Sheets("Sheet2")?
Sub MoveData()
Dim r As Range
If ThisWorkbook.Worksheets(1).Shapes("Check Box 1").OLEFormat.Object.Value = 1 Then
Set r = Worksheets(1).Range("A2:B2:C2:D2:E2:F2:G2:H2:I2:J2:K2:L2:M2")
Sheets("Sheet2").Range("A1").Resize(1, r.Count) = r.Value
'r.ClearContents
End If
End Sub
Instead of cut and paste try the following.
Sub MoveData()
If ThisWorkbook.Worksheets(1).Shapes("Check Box 1").OLEFormat.Object.Value = 1 Then
Sheets("Sheet2").Range("A1:M1").Formula = Sheets("Sheet1").Range("A2:M2").Formula
Range("A1").Select
End If
End Sub
Edit:
If you were cutting to remove the originals from Sheet1 just use,
Sheets("Sheet1").Range("A2:M2").Clear
I want to make drop Down List in sheet2 which contains values from sheet1 column. I have tried this code.
Sub testIt()
Dim r As Long, endRow As Long, pasteRowIndex As Long
endRow = 10 ' of course it's best to retrieve the last used row number via a function
pasteRowIndex = 1
For r = 1 To endRow 'Loop through sheet1 and search for your criteria
If Cells(r, Columns("B").Column).Value = "YourCriteria" Then 'Found
'Copy the current row
Rows(r).Select
Selection.Copy
'Switch to the sheet where you want to paste it & paste
Sheets("Sheet2").Select
Rows(pasteRowIndex).Select
ActiveSheet.Paste
'Next time you find a match, it will be pasted in a new row
pasteRowIndex = pasteRowIndex + 1
'Switch back to your table & continue to search for your criteria
Sheets("Sheet1").Select
End If
Next r
columns in sheet1 are changing oftenly. so needs to create Dynamic VBA Macro code.
Please guide me for this query.
For your case, I don't think that you need a macro to manage the drop down list but perhaps data validation will do.
Create a new worksheet,
I got a worksheet contain the following data at column A
At the worksheet that i want the dropdownlist, i just highlight the cell and click on the data validation button at data ribbon
In the data validation, create the following setting
Click on the ok button and the list will be created
Since in the columns in the worksheet(source) keep on changing, you need write the macro to copy the entire needed column exclude the header of the column to next worksheet(e.g. worksheet that create the dropdown list).
Edited: Code to detect the criteria column and copy the column
Option Explicit
Dim MyWorkbook As Workbook
Dim MyWorksheet As Worksheet
Dim MyWorksheet2 As Worksheet
Dim WantedColumn As Long
Dim ColumnPointer As Long
Sub copyCriteria()
Set MyWorkbook = Workbooks(ActiveWorkbook.Name)
Set MyWorksheet = MyWorkbook.Sheets("Sheet6")
Set MyWorksheet2 = MyWorkbook.Sheets("Sheet5")
For ColumnPointer = 1 To MyWorksheet.Cells(1, Columns.Count).End(xlToLeft).Column
If MyWorksheet.Cells(1, ColumnPointer).Value = "ColumnE" Then
MyWorksheet.Columns(ColumnPointer).Copy
MyWorksheet2.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
MyWorksheet2.Rows("1:1").Delete Shift:=xlUp
End If
Next
End Sub
What you are trying to do can be done with a simple named range and Data Validation to use that Name. If you have not heard of Dynamic Ranges, then you should read on.
If Sheet1 only has the 1 column for the DropDown list via Data Validation, you should use a Named Range instead of a fixed Range. But this named range is dynamic (by using formula)! See OFFSET usage.
Lets say Sheet1 is like below:
Lets say the name to be used is MyList, then in Excel click Name Manager in Formulas tab, and place in below as the Range Refers to:
=OFFSET(Sheet1!$A$1,0,0,COUNTA(Sheet1!$A:$A))
Now in Sheet2, the Data Validation is placed on B2, when setting it up, once you put in the source to =MyList, Excel highlights it:
Then the drop down list worked:
Now if you add data to your list (Column A on Sheet 1), the MyList automatically expands and hence your DataValidation drop down list!
Note the list will go up to the first blank cell in Column A, so NO GAPS!
Enjoy!
I am trying to create an excel macro which is probably going to end up being quite large, to make things easier I am tackling it a bit at a time. So far I have....
Sub Macro4()
'
' Test Macro
'
'Selects the product_name column by header name
Dim rngAddress As Range
Set rngAddress = Range("A1:Z1").Find("product_name")
If rngAddress Is Nothing Then
MsgBox "The product_name column was not found."
Exit Sub
End If
Range(rngAddress, rngAddress.End(xlDown)).Select
'Inserts new column to the left of the product_name column
Selection.Insert Shift:=xlToRight
'Re-selects the product_name column
Range(rngAddress, rngAddress.End(xlDown)).Select
'Copys the contents of the product_name column
Selection.Copy
Selection.Paste
End Sub
I want it to do the following....
Search the spreadsheet for the header name 'product_name'
Insert a blank column to the left of the 'product_name' column
Copy the contents of the 'product_name' column
Paste them into the newly created blank column
Change the header name in this new column to 'product_name_2'
Currently it works fine up until the pasting into this newly created column, then i get a
'Run-time error '438'; - Object doesn't support this property or method'
Can anyone suggest where i am going wrong?
Your error is:
Range(rngAddress, rngAddress.End(xlDown)).Select
This selects from the top of the column down to just above the first blank cell. The insert shifts this portion of the column right leaving the rest where it is. When you select again you are likely to get a larger range because you have mixed two columns. The copy fails because you are then trying to copy values over the top of values.
If that does not make sense, step through your macro with F8 and see what is happening at each step.
When you understand why your current macro does not work, try this:
Sub Macro5()
Dim rngAddress As Range
Dim ColToBeCopied As Integer
Set rngAddress = Range("A1:Z1").Find("'product_name")
If rngAddress Is Nothing Then
MsgBox "The product_name column was not found."
Exit Sub
End If
ColToBeCopied = rngAddress.Column
Columns(ColToBeCopied).EntireColumn.Insert
Columns(ColToBeCopied + 1).Copy Destination:=Columns(ColToBeCopied)
End Sub
Note:
I did not select anything.
I have left the code operating on the active sheet but it is better to use With Sheets("XXX") ... End With.
Answer to second question
The macro recorder is not good at showing how to address individual cells systematically.
With Sheets("xxxx")
.Cells(RowNum,ColNum).Value = "product_name 1"
End With
The above uses With which I recommend. Notice the dot in front of Cells.
The one below operates on the active sheet.
Cells(RowNum,ColNum).Value = "product_name 1"
RowNum must be a number. ColNum can be a number (say 5) or a letter (say "E").
In your case RowNum is 1 and ColNum is ColToBeCopied and ColToBeCopied + 1.
P.S.
I forgot to mention that to find the botton row of a column use:
RowLast = Range(Rows.Count, ColNum).End(xlUp).Row
That is move up from the bottom not down from the top.
P.S. 2
To specify a range using Cells:
.Range(.Cells(Top,Left),.Cells(Bottom,Right))
The dots must match: all three or none.
I'm not sure where you are trying to copy to,
but when you want to paste you need to make a selection and then
ActiveSheet.Paste
For example:
/your code/
Selection.Copy
Range("O:O").Select
ActiveSheet.Paste
I would avoid copying / pasting altogether, if you only want to transfer values.
For example, instead of:
Range("B1:B100").Copy Destination:=Range("A1")
I would use:
Range("A1:A100").Value = Range("B1:B100").Value
If we were to substitute that into your code, and include some of the comments made by Tony:
Sub Macro4()
Dim colFound As Integer
Dim rowLast As Long
Const rowSearch As Integer = 1
'Find the product_name column
colFound = Rows(rowSearch).Find("product_name").Column
If colFound = 0 Then
MsgBox "The product_name column was not found."
Exit Sub
End If
'Find the last non-empty row
rowLast = Cells(Rows.Count, colFound).End(xlUp).Row
'Inserts new column to the left of the product_name column
Columns(colFound).EntireColumn.Insert
'Transfer the contents of the product_name column to the newly inserted one
Range(Cells(rowSearch, colFound), Cells(rowLast, colFound)).Value = _
Range(Cells(rowSearch, colFound + 1), Cells(rowLast, colFound + 1)).Value
'Rename the new column
Cells(rowSearch, colFound).Value = Cells(rowSearch, colFound).Value & "_2"
End Sub