Sub CPRow()
Range("D14:K14").Select
Selection.Copy
Range("D15").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
i want to add code to do the following:
1- if the sheet name begins with a number then copy the range (D14:K14) and paste it in Range (D15:K15) as Values.
2- Go to next sheet and do the same, and stop when there is a sheet with no number or until sheet name starts with a letter.
Any help is appreciated.
The code below will copy Range("D14:K14") form Worksheets("Sheet1") (modify "Sheet1" to your sheet's name), and paste it to all worksheet's that their Name start with a number.
Option Explicit
Sub CPRow()
Dim Sht As Worksheet
Dim ShttoCopy As Worksheet
Set ShttoCopy = Worksheets("Sheet1") ' <-- modify "Sheet1" to the sheet you want to copy Range("D14:K14") from
For Each Sht In ThisWorkbook.Worksheets
If IsNumeric(Left(Sht.Name, 1)) Then
ShttoCopy.Range("D14:K14").Copy
Sht.Range("D15").PasteSpecial xlPasteValues
End If
Next Sht
End Sub
Related
I have the following to copy a range of free text boxes to another series of cells, which works as I want it to:
Public Sub LogEntry()
'define source range
Dim SourceRange As Range
Set SourceRange = ThisWorkbook.Worksheets("Log").Range("C4:J4")
'find next free cell in destination sheet
Dim NextFreeCell As Range
With ThisWorkbook.Worksheets("Log")
If IsEmpty(.Range("C8").Value) Then
Set NextFreeCell = .Range("C8")
Else
Set NextFreeCell = .Cells(.Rows.Count, "C").End(xlUp).Offset(1)
End If
End With
'copy & paste
SourceRange.Copy
NextFreeCell.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
NextFreeCell.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'delete text box
ThisWorkbook.Save
Application.Goto Reference:="R4C7:R4C9"
Application.CutCopyMode = False
Selection.ClearContents
End Sub
In my original fields, in box J4, I have a drop down list. How do I copy this to the new location and maintain the list functionality? I also want to add conditional formatting to the selections in this box so would like this carried forward also?
If you copy (rather than Copy followed by PasteSpecial) a cell, the data validation will copy with it:
the code:
Sub KopyKat()
Dim J4 As Range, K5 As Range
Set J4 = Range("J4")
Set K5 = Range("K5")
J4.Copy K5
End Sub
the result:
So I'm trying to run a column through a table in Excel using VBA. I then want to copy the result and paste in another column. I've gotten it to work for one cell, however, when I try to loop the code, it just pastes the same thing in every cell in the range I want it to paste in. How do I make it so that when it loops, it only pastes in the single cell vs. the entire range? My code is below.
Sub Test1()
'
' Test1 Macro
'
'
Dim rng As Range, cell As Range
Set rng = Range("C16:C20")
For Each cell In rng
Dim rng2 As Range, cell2 As Range
Set rng2 = Range("G16:G20")
For Each cell2 In rng2
cell.Select
Selection.Copy
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D12").Select
Application.CutCopyMode = False
Selection.Copy
rng2.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Tranpose:=False
'ActiveCell.Offset(1, 0).Select
Next cell2
Next cell
End Sub
Thanks!
Guessing you want something like this:
Sub Test1()
Dim rng As Range, cell As Range, ws As Worksheet
Set ws = ActiveSheet
Set rng = ws.Range("C16:C20")
For Each cell In rng.Cells
ws.Range("B4").value = cell.Value
cell.offset(0, 4).value = ws.Range("D12").Value 'populate in Col G
Next cell
End Sub
Note there's typically no need to select/activate anything in excel (though the macro recorder does that a lot). Worth reviewing this: How to avoid using Select in Excel VBA
Likewise if you need to transfer values between cells you can do that directly without copy/paste.
I'm new to VBA. I use a one column array for the variable data. Starting at the first cell (A1) I want to copy the text value in A1, paste to Sheet2,in A5, go back to the array and do it all over again, until I get to an empty cell. Easy right?
Here is the code that I have, I can not copy the value and paste it.
Thank you, for your suggestions!!!
Sub copylist()
' copylist Macro
Worksheets("ID nbr").Select
Range("B3").Select
For Each c In Worksheets("ID nbr").Range("B3:B20").Cells
If c.Value <> "" Then
Sheets("ID nbr").Select
Dim rgCopy As Range
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("B4:G4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Findings").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End If
Next
End Sub
You have made a great attempt using the macro recorder. Now let's clean it up:
I moved all the sheets into variables to limit the amount of typing.
I removed all the .Select and .Activate, these just slow the code down and if referenced properly they are not needed.
When only values are wanted, then assigning them directly is quicker than using the clipboard. We can do this as one block of cells.
I used a counter to move down one row on the target sheet for every row found in the original sheet.
The code:
Sub copylist()
Dim ows As Worksheet
Dim tws As Worksheet
Dim c As Range
Dim i As Long
Set ows = Sheets("ID nbr") 'Original sheet
Set tws = Sheets("Findings") 'Target sheet
i = 4 'this is the first row in the target sheet
With ows
For Each c In .Range("B3:B20").Cells
If c.Value <> "" Then
tws.Range(tws.Cells(i, "B"), tws.Cells(i, "G")).Value = .Range(.Cells(c.Row, "B"), .Cells(c.Row, "G")).Value
i = i + 1
End If
Next c
End With
End Sub
I have the following macro which has worked great for copy and paste, then the person working with the workbook goes to the newly created sheet and starts deleting rows not necessary to the end product. I have tried adding a line to have the macro delete blank rows, but it is not working. I think possibly because it is not on the active sheet? If I could get the macro to delete blank rows in the range I have added to the macro then I can build from there; as we have many ranges to look through and delete from. I am still learning about macros so any education you could give me would be much appreciated.
Here is the macro I have. It is the 'Delete lines from new sheet that is not working.
Sub CopyandPaste()
'Copy and Paste to Worksheets
'
'Select from MASTER sheet
Range("A1:H1500").Select
Selection.Copy
' Add new sheet for each Tech
Sheets.Add After:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
'Copy again to paste values
Range("A1:H1500").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Name new sheet Tech's name
Sheets(Sheets.Count).Select
Sheets(Sheets.Count).Name = Sheets(Sheets.Count).Range("a2").Value
'Delete blank lines from new sheet
ActiveSheet.Range("F282:F834").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
The routine below is how I might tackle this task. Comments are included to help explain what's going on:
Option Explicit
Sub CopyAndPasteRev2()
Dim Source As Range, Dest As Range, Remove As Range
Dim Master As Worksheet, Target As Worksheet
'set references up-front, assuming you
'start with the MASTER sheet active
Set Master = ThisWorkbook.ActiveSheet
Set Source = Master.Range("A1:H1500")
Set Target = ThisWorkbook.Sheets.Add
Set Dest = Target.Range("A1")
'copy range from master to target
Source.Copy Destination:=Dest
'copy the column width formatting from master to target
Source.Copy
Dest.PasteSpecial (xlPasteColumnWidths)
'remove rows that are blank in col F using
'autofilter to look for empty cells
Dest.AutoFilter
With Target.AutoFilter.Range
.AutoFilter Field:=6, Criteria1:=vbNullString
Set Remove = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
Remove.Delete Shift:=xlUp
End With
'clear filters safely
With Target
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
'move target sheet to be the last one in the workbook
Target.Move After:=ThisWorkbook.Worksheets(Sheets.Count)
End Sub
In most case runtime exception are caused by the Select and ActiveSheet methods.
You need to use them less as possible and use Range and Worksheet variables instead :
Sub CopyandPaste()
'Copy and Paste to Worksheets
'
'Select from MASTER sheet
Dim MasterSheet As Worksheet
Set MasterSheet = Sheets("Master")
MasterSheet.Range("A1:H1500").Copy
Dim newSheet As Worksheet
' Add new sheet for each Tech
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
newSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
newSheet.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Copy again to paste values
Application.CutCopyMode = False
'Name new sheet Tech's name
On Error Resume Next
Sheets.Item(newSheet.Range("a2").Value).Delete
On Error GoTo 0
newSheet.Name = newSheet.Range("a2").Value
'Delete blank lines from new sheet
For i = 834 To 282 Step -1
With newSheet.Cells(i, "F")
If .Text = "" Then .EntireRow.Delete
End With
Next i
End Sub
I have a range of data that is in the same position in every worksheet in a book and will always be in that position. When the macro is run the data should be copied and added to a report sheet. I have that part working but I need to use a paste special:
.PasteSpecial xlPasteValues
as there are formulas in the range. I am unsure where to add the paste special condition in this code, since I'm using .Copy, Destination.
Option Explicit
Sub CreateTempPSDReport()
Dim WS As Worksheet, Rept As Worksheet
Set Rept = Sheets("Temporary PSD Report")
Application.ScreenUpdating = False
'--> Loop through each worksheet except the report and
'--> Copy the set range to the report
For Each WS In ThisWorkbook.Worksheets
If Not WS.Name = "Temporary PSD Report" Then
WS.Range("A42", "I42").Rows.Copy _
Destination:=Rept.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next
Application.ScreenUpdating = True
End Sub
I need to use a paste special:
WS.Range("A42", "I42").Rows.Copy _
Destination:=Rept.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
In such a case you do not use the above method. You use this
WS.Range("A42", "I42").Rows.Copy
Rept.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False