I have a column with unknown number of rows in one sheet, i'd like to copy it and paste on another sheet. As far number of rows is unknown I define it as a variable:
Sub Official()
Dim lastrow As Long
Dim LastCol As Long
Set currentsheet = ActiveWorkbook.Sheets(1)
LastRow = Range("A65536").End(xlUp).Row
LastCol = Range("A1").End(xlToRight).Column
Sheets("Type_1").Range("D8" & "D" & LastRow).Copy
Sheets(1).Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub
I get an error to this macro, maybe someone can help me?
you could try:
Sub Official()
Dim lastrow As Long
Dim LastCol As Long
Dim srcLastRow As Long
Set currentsheet = ActiveWorkbook.Sheets(1)
' handle Office 2007+ with more than 65536 rows...
lastrow = Range("A" & currentsheet.Rows.Count).End(xlUp).Row
LastCol = Range("A1").End(xlToRight).Column
' find out how many rows there are in the source sheet
srcLastRow = Sheets("Type_1").Range("D" & Sheets("Type_1").Rows.Count).End(xlUp).Row
' copy from the course sheet to the currentSheet in the range specified
Sheets("Type_1").Range("D8:" & "D" & srcLastRow).Copy Destination:=currentsheet.Range("A" & lastrow)
' or maybe you want:
' Sheets("Type_1").Range("D8:" & "D" & srcLastRow).Copy Destination:=currentsheet.Cells(lastrow, LastCol)
End Sub
Related
I am a military recruiter and am trying to use autofilter to filter out a range from another range. I got this from another stackoverflow page but can not figure out how to change that string strSearch to a range like 123#gmail, 234#gmail, 345#gmail, etc.
We get lists of leads but I'd like to keep the running list of opt-outs and have VBA double check and delete any cells that have a value from the opt-out worksheet. I am pretty new to VBA but really enjoy it. Thank you!
I'd like it to be strSearch = Sheets("Opt-Outs").Range("A:A") so that it takes all values in A:A and uses them as an autofilter. I believe it needs to be a string array but am lost as how to get there. Please help.
Sub optout20171227()
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As String
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("A2")
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub
This should do it...
Sub optout20171227()
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As String
Dim v() As Variant
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("A2")
v = Application.Transpose(Sheets("Opt-Outs").Range("A:A"))
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:=v
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
Dim ws As Worksheet
Dim lRow As Long
Dim strSearch As Variant
Dim i As Integer
i = 1
Sheets("Opt-Outs").Select
Range("H2").Value = "Ready"
Range("A2").Select
Do While Range("H2").Value <> Empty
Sheets("Opt-Outs").Select
Range("A2").Select
Cells(i + 1, 1).Copy
i = i + 1
Range("H2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If Range("H2").Value = IsBlank Then
Sheets("Email Addresses").Select
Exit Sub
Else
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Worksheets("Email Addresses")
'~~> Search Text
strSearch = Sheets("Opt-Outs").Range("H2")
With ws
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range("A" & .Rows.count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End If
Loop
I have written a macro to create a variable number of worksheets based on a list in worksheet "ProjList". Each sheet is named at the time of creation. I am trying to copy the values in some of the cells (Columns A-D) from "ProjList" to the new sheets. I've successfully done it with with a paste command, but I want the data transposed.
I have written:
Sub AddWorkSheets()
Dim RowNumb As Long
Dim LastRow As Integer
LastRow = Worksheets("ProjList").Cells(Worksheets("ProjList").Rows.Count, "D").End(xlUp).Row
For RowNumb = 2 To LastRow
Sheets("ProjList").Activate
Worksheets("ProjList").Range("A" & RowNumb, "D" & RowNumb).Copy
Sheets.Add
ActiveSheet.Name = Worksheets("ProjList").Cells(RowNumb, 4).Value
ActiveSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Range("D1").PasteSpecial Paste:=xlPasteValues, transpose:=True
Next RowNumb
End Sub
I get a
RunTime Error 1004: PasteSpecial method of range class failed.
The first worksheet gets created, but the macro fails at the PasteSpecial line.
Any help is much appreciated.
Thank you!
Try This:
ActiveSheet.Range("D1").Resize(, 4).PasteSpecial Paste:=xlPasteValues, transpose:=True
try this code bellow:
Sub AddWorkSheets()
Dim RowNumb As Long
Dim LastRow As Integer
LastRow = Worksheets("ProjList").Cells(Worksheets("ProjList").Rows.Count, "D").End(xlUp).Row
For RowNumb = 2 To LastRow
Sheets("ProjList").Activate
Sheets.Add
ActiveSheet.Name = Worksheets("ProjList").Cells(RowNumb, 4).Value
ActiveSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Range("D1").Resize(, 4) = Application.WorksheetFunction.Transpose(Worksheets("ProjList").Range("A" & RowNumb, "D" & RowNumb))
Next RowNumb
End Sub
I have a workbook with multiple sheets, in each sheet I need to copy the same row contents to my master list. I have a code to get one cell value (which is N7) in each sheet to my master,
The problem is, in some sheets, the cell value to be get into master will be one cell , In other sheets, it will be two or more cells like (N7 TO N11)
How should I get this in to my master?
My current code is,
Dim DataFile As String
Workbooks.Open Filename:=Range("T3").Value
DataFile = ActiveWorkbook.Name
ThisWorkbook.Activate
Range("C4").Select
For i = 1 To Workbooks(DataFile).Worksheets.Count
ActiveCell.Value = Workbooks(DataFile).Worksheets(i).Range("N7").Value
ActiveCell.Offset(1, 0).Select
Next i
Please help me on this.
The following should work nicely, provided that you change the MasterFileSheetNameHere to your sheet name
Option Explicit
Sub CopyFromEachSheet()
Dim CurrentWorkSheet As Worksheet
Dim DataFile As Workbook
Dim DataFileLastRow As Long
Dim MasterFileSheet As Worksheet
Dim MasterFileLastRow As Long
Dim RangeToCopy As Range
Dim DataFileRowCount As Long
'Assuming that this scipt will be in your master file
'Replace with youor sheet name
Set MasterFileSheet = ThisWorkbook.Sheets("MasterFileSheetNameHere")
Set DataFile = Workbooks.Open(Filename:=MasterFileSheet.Range("T3").Value)
For Each CurrentWorkSheet In DataFile.Sheets
With MasterFileSheet
MasterFileLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
With CurrentWorkSheet
DataFileLastRow = .Cells(.Rows.Count, "N").End(xlUp).Row
End With
Set RangeToCopy = CurrentWorkSheet.Range("N7:N" & DataFileLastRow)
'To insert rows before pasting into new rows
If RangeToCopy.Rows.Count > 1 Then
'-1 to counter the +2 below so that the additional rows are added below the first row in MasterFile
For DataFileRowCount = 1 To RangeToCopy.Rows.Count - 1
MasterFileSheet.Range("C" & MasterFileLastRow + 2).EntireRow.Insert xlDown
Next DataFileRowCount
End If
'Use this code to paste the values from DataFile to MasterFile
RangeToCopy.Copy MasterFileSheet.Range("C" & MasterFileLastRow + 1 & _
":C" & MasterFileLastRow + 1 + RangeToCopy.Rows.Count)
'Use this code if you want to transpose
'+1 here allows you to insert to the next unused line
'MasterFileSheet.Range("C" & MasterFileLastRow + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
Next CurrentWorkSheet
End Sub
HI Divya The below code may be helpful to u
Sub Selectvalue()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Lastrow = Workbooks("Mastersheet").Sheets("sheet1").Range("C" & Rows.Count).End(xlUp).Row
Workbooks("Mastersheet").Sheets("sheet1").Range("C" & Lastrow).Offset(1, 0) = ws.Range("N7:N" & Cells(Rows.Count, "N").End(xlUp).Row)
Next ws
End Sub
Please help me with the following problem:
I have 3 ranges each on a different sheet.
I have to copy every range (till its last row with data and paste values with all of them on sheet "Rezultat" (in order so they will not paste on each other)
This is my code:
Sub MultipleRangesPaste()
Dim rng1 As Range, rng2 As Range, rng3 As Range, MultipleRng As Range
With ThisWorkbook.Sheets("REZULTAT")
Set rng1 = Sheets("NEVOI PERSONALE").Range("F2:H" & Range("H" & Rows.Count).End(xlUp).Row)
Set rng2 = Sheets("RATE").Range("F2:H" & Range("H" & Rows.Count).End(xlUp).Row)
Set rng3 = Sheets("CARDURI").Range("G2:I" & Range("I" & Rows.Count).End(xlUp).Row)
Set MultipleRng = .Range(rng1 & rng2 & rng3) ' AT THIS LINE DEBUG SAID IT IS A PROBLEM
End With
MultipleRng.Copy
With ThisWorkbook.Sheets("REZULTAT").Range("A2")
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
End Sub
My idea is pretty much as the one of #Shai Rado, but I did not write the whole code (that pleasure was intended for the OP) and I have a function, that locates the last used row, based on a column:
Option Explicit
Sub MultipleRangesPaste()
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim MultipleRng As Range
Dim lngRowSource As Long
Dim lngRowTarget As Long
Dim lngRows As Long
With ThisWorkbook.Sheets("REZULTAT")
Set rng1 = Sheets("NEVOI PERSONALE").Range("F2:H" & Range("H" & Rows.Count).End(xlUp).Row)
Set rng2 = Sheets("RATE").Range("F2:H" & Range("H" & Rows.Count).End(xlUp).Row)
Set rng3 = Sheets("CARDURI").Range("G2:I" & Range("I" & Rows.Count).End(xlUp).Row)
End With
rng1.Copy
With ThisWorkbook.Sheets("REZULTAT").Range("A2")
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
rng2.Copy
'here locate the last row of column A in ThisWorkbook.Sheets("REZULTAT") and paste from there
rng3.Copy
'here locate the last row of column A in ThisWorkbook.Sheets("REZULTAT") and paste from there
End Sub
Public Function last_row(Optional str_sheet As String, Optional column_to_check As Long = 1) As Long
Dim shSheet As Worksheet
If str_sheet = vbNullString Then
Set shSheet = ThisWorkbook.ActiveSheet
Else
Set shSheet = ThisWorkbook.Worksheets(str_sheet)
End If
last_row = shSheet.Cells(shSheet.Rows.Count, column_to_check).End(xlUp).Row
End Function
I usually use application.Union, but it doesn't work on multiple ranges from different worksheets. So in this case, you have to do it manually, copy>>paste each range, into the next available row.
Sub MultipleRangesPaste()
Dim rng1 As Range, rng2 As Range, rng3 As Range, MultipleRng As Range
Dim NextRow As Long
Set rng1 = Sheets("NEVOI PERSONALE").Range("F2:H" & Sheets("NEVOI PERSONALE").Cells(Sheets("NEVOI PERSONALE").Rows.Count, "H").End(xlUp).Row)
Set rng2 = Sheets("RATE").Range("F2:H" & Sheets("RATE").Cells(Sheets("RATE").Rows.Count, "H").End(xlUp).Row)
Set rng3 = Sheets("CARDURI").Range("G2:I" & Sheets("CARDURI").Cells(Sheets("CARDURI").Rows.Count, "I").End(xlUp).Row)
With ThisWorkbook.Sheets("REZULTAT")
' find current next empty row on Column A
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
rng1.Copy
.Range("A" & NextRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
' find current next empty row on Column A
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
rng2.Copy
.Range("A" & NextRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
' find current next empty row on Column A
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
rng3.Copy
.Range("A" & NextRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End With
End Sub
I am trying to create some code that looks through a range of cells and will copy and paste the cells that meet a specific parameter to a different location in the workbook.
I would like to copy anything with the letter L from "sheet5" and copy a specific range to "sheet1"
I must have something wrong with the loop part of the code because only the top of the cell range is being copied. I would like the pasting to start at row 5 and continue moving downward. Does this mean I correctly put the IRow = IRow + 1 below the paste function?
Sub Paste_Value_Test()
Dim c As Range
Dim IRow As Long
Dim rDestination As Excel.Range
Application.ScreenUpdating = False
Sheets("sheet5").Activate
For Each c In Sheets("sheet5").Range("b2", Range("N65536").End(xlUp))
If c.Value = "L" Then
Sheets("sheet5").Cells(c.Row, 2).Copy
Set rDestination = Worksheets("sheet5").Cells(5 + IRow, 12)
rDestination.Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
IRow = IRow + 1
End If
Next c
End Sub
I really appreciate any help on this. I'm relatively new to VBA and am going to start seriously digging in.
Is this what you are trying by any chance? I have commented the code so you shouldn't have any problem understanding it.
Sub Paste_Value_Test()
Dim c As Range
Dim IRow As Long, lastrow As Long
Dim rSource As Range
Dim wsI As Worksheet, wsO As Worksheet
On Error GoTo Whoa
'~~> Sheet Where "L" needs to be checked
Set wsI = ThisWorkbook.Sheets("Sheet5")
'~~> Output sheet
Set wsO = ThisWorkbook.Sheets("Sheet1")
Application.ScreenUpdating = False
With wsI
'~~> Find Last Row which has data in Col B to N
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastrow = .Columns("B:N").Find(What:="*", _
After:=.Range("B1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastrow = 1
End If
'~~> Set you input range
Set rSource = .Range("B2:N" & lastrow)
'~~> Search for the cell which has "L" and then copy it across to sheet1
For Each c In rSource
If c.Value = "L" Then
.Cells(c.Row, 2).Copy
wsO.Cells(5 + IRow, 12).PasteSpecial Paste:=xlPasteValues
IRow = IRow + 1
End If
Next
End With
LetsContinue:
Application.ScreenUpdating = True
Application.CutCopyMode = False
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub