I am trying to loop through a range of cells in a column and find non-blank cells to generate multiple template worksheets based on cell value in that specific range for further data transfer. however I am getting a debugging error, can anyone solve a problem? In the attached code "CETIN is the template worksheet
Sub generateSheet()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Sheets("CETIN")
Set sh2 = Sheets("Combine")
Range("A4:A600").Select
Selection.AutoFilter
ActiveSheet.Range("$A$5:$A$116").AutoFilter Field:=1, Criteria1:="<>"
Range("A4:A64").Select
Range("A4:A64").Select
Range("A4:A600").Select
Range("A116").Activate
Selection.Copy
Range("AT5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.AutoFilter
For Each c In sh2.Range("AT5", sh2.Cells(Rows.Count, 46).End(xlUp))
sh1.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
Next
End Sub
Related
data set
Hi All,
I know its abasic stuff but trying to learn VBA and encountered this issue while building my first macro. I have completely no idea how to pull this through.
I have a data set in sheet1 - an array of 9 columns with headers (the range is not definite and will vary month to month) out of which I need to populate the data into a form in sheet2. The problem is that the form is just built manually across spreadsheet2. Someone just drew a table and adapted it as a form and it cannot be changed (just some requirement) Another thing is that table was created in a way where some cells are one above the other so 2 rows would contain the data of one in the source. I placed the photos that should paint the picture of what Im trying to say. So the only thing I knew is how to copy one row of data but have no idea how to loop it so that each next row from spread sheet1 will populate itself accordingly among these two other rows. So the idea is for the macro to copy data from the source and create necessary number of these double rows until the source data runs out(dependantly on how bit source range will be as its dynamic) At the end there must be that summary of TOtal from last row.
Ive tried it like this
Sub sbCopyRangeToAnotherSheet()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
ws1.Sheets("51").Range("H2").Copy
Sheets("Add 51").Range("A11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("51").Range("C2").Copy
Sheets("Add 51").Range("B11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("51").Range("E2").Copy
Sheets("Add 51").Range("D10").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("51").Range("F2").Copy
Sheets("Add 51").Range("D11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("51").Range("D2").Copy
Sheets("Add 51").Range("E11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Sheets("51").Range("I2").Copy
Sheets("Add 51").Range("I11").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
Untested:
Sub Tester()
Dim rngDest As Range, rwSrc As Range, arr, i As Long
Set rwSrc = ThisWorkbook.Worksheets("51").Range("C2:H2") 'first row of source data
Set rngDest = ThisWorkbook.Worksheets("Add 51").Range("A5:I6") 'destination for first row
arr = Array("B2", "D2", "D1", "E1", "E2", "I2") 'array of *relative* addresses
Do While Application.CountA(rwSrc) > 0 'while there's any data in the source row
For i = 1 To rwSrc.Cells.Count 'loop over cells in source row
'set value of a cell in `rngDest` using relative range address from `arr`
rngDest.Range(arr(i - 1)).Value = rwSrc.Cells(i).Value 'i-1 because arr is zero-based
Next i
Set rwSrc = rwSrc.Offset(1) 'next source row
Set rngDest = rngDest.Offset(rngDest.Rows.Count) 'next destination block
Loop
End Sub
Relies on Range() being relative to the object it's called on, so for example
Range("B2:C4").Range("A1") is B2
Range("B2:C4").Range("B2") is C3
Sub Copy_Cell2()
'Declare Variables
Dim Wr As Worksheet
'Define the excel sheet
Set Wr = ThisWorkbook.Sheets("Sheet2")
'Code to stop screen updating and flickering ON
Application.ScreenUpdating = False
'Select Sheet1 to get the random value
Sheets("Sheet1").Select
Cells.Select
Range("F1").Select
Range("F1").Copy
'Selects Sheet2 to paste the random value in the next blank cell in column A
Sheets("Sheet2").Select
Range("A2").Select
nrlife = Wr.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
'Establish what row has been selected
With ActiveCell
vRow = .Row
End With
vRange = "A" & vRow & ""
Range(vRange).Select
'Code to paste value and format from Sheet1 to first empty row on sheet2
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks_:=False, Transpose:=False
'Code to stop screen updating and flickering OFF
Application.ScreenUpdating = True
End Sub
I am getting error in Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks_:=False, Transpose:=False
Error code is Run-time error '1004' Aplication-defined or
object-defined error
Can anyone help me what am i missing?
Your code reduces to:
Dim wb As Workbook
Set wb = ThisWorkbook
wb.Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1).Value = _
wb.Sheets("Sheet1").Range("F1").Value
You can assign values directly - no need for copy/paste in this case.
Could you please help me out with below formula? It gives object defined or app defined error. Thanks a lot.
Sub cellstovalues()
Sheets("Parsing").Select
Columns("B:B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
As an alternative, you can simply assign the values to the Value2 (or Value) property of the range:
Sub cellstovalues()
With Sheets("Parsing")
With Intersect(.Range("B:B"), .UsedRange)
.Value2 = .Value2
End With
End With
End Sub
or for a specific range:
Sub cellstovalues()
With Sheets("Parsing").Range("B1:C10")
.Value2 = .Value2
End With
End Sub
Your code is having issues from you selecting the entire column B. Try using this. This should find the last used cell in your column, then copy and paste to convert the formulas to values like you want.
Sub cellstovalues()
Dim ws As Worksheet
Dim LastRow As Integer
Dim rng As Range
Set ws = ThisWorkbook.Sheets("Parsing")
With ws
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rng = .Range(.Cells(1, "B"), .Cells(LastRow, "B"))
End With
rng.Copy
rng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
I have researched this issue on several different sites with no clear way to do what I want:
I have a spreadsheet with 68 pairs of columns from 'B' to 'EG' and one leading column of data in 'A'.
I want create a new worksheet and name it for the header for the first column of each pair of columns, then copy the column of data in 'A' and the pair of columns into the new worksheet, and do the same for each succeeding pair of columns. I can create the new worksheets from the existing spreadsheet data, but not sure how to name the new worksheets to match the header field.
The following code will create a new worksheet and copy the data, but it won't name the worksheet, and I have to create 68 separate blocks for each succeeding pair of columns! Can anyone suggest a mod to the code to loop through the columns and do what I want? Generated code is below! And any real help would be very much appreciated.
Thanks Mike
Code:
Sub testcopy()
testcopy Macro
Keyboard Shortcut: Ctrl+f
Range("A5:A17,B5:B17,C5:C17").Select
Range("C5").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
Range("A5:A17,D5:D17,E5:E17").Select
Range("E5").Activate
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
.
.
.
End Sub
Something like this:
Sub testcopy()
Dim shtSrc As Worksheet, sht As Worksheet
Dim i As Long, rngA As Range, rngTwo As Range
Set rngA = ActiveSheet.Range("A5:A17")
Set rngTwo = ActiveSheet.Range("B5:C17")
For i = 1 To 68
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
sht.Name = rngTwo.Cells(1).Value
Application.Union(rngA, rngTwo).Copy
sht.Range("A5").PasteSpecial Paste:=xlPasteValues
Set rngTwo = rngTwo.Offset(0, 2)
Next i
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