In the code below, I am building a table on the "Shipped" sheet by pulling data from the "Efficiency" sheet using the criteria "Ship". I want to name the "Shipped" sheet dynamically from a cell by using something like Application.ActiveSheet.Name = .Range("A2") and then use that to call the sheet using something like Set wsShip = Worksheets.Range("A2") and I also want to use a dynamic criteria for pulling data, so instead of using Criteria1:="Ship"I want to use Criteria1:=.Range("A3") Is there any/another way to do this?
Sub DataTable()
Dim wsEff As Worksheet
Dim wsShip As Worksheet
''Application.ActiveSheet.Name = Range("A2")
'Need ' Set wsShip = Worksheets(Range("A2"))?
Set wsShip = Worksheets("Shipped")
Set wsEff = Worksheets("Efficiency")
With wsEff
Dim lRow As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:H" & lRow).AutoFilter Field:=2, Criteria1:="Ship"
Dim rngCopy As Range
'All Columns A:H
Set rngCopy = .Columns("A:H")
'filtered rows, not including header row - assumes row 1 is headers
Set rngCopy = Intersect(rngCopy, .Range("A1:H" & lRow), .Range("A1:H" & lRow).Offset(1)).SpecialCells(xlCellTypeVisible)
rngCopy.Copy
End With
wsShip.Range("A4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Efficiency").ShowAllData
End Sub
Set wsShip = Worksheets("Shipped")
Set wsEff = Worksheets("Efficiency")
wsShip.Name = wsEff.Range("A2").Value 'for example
wsShip.Activate 'changing the name doesn't change the reference to
' the sheet you have in 'wsShip'
Related
I am unable to stop my VBA from looping within the range that I have specified, could someone please check my code and tell me where I am going wrong with it.
Option Explicit
Sub Macro()
Dim oWs As Worksheet
Dim rSearchRng As Range
Dim lEndNum As Long
Dim vFindVar As Variant
Dim loc As Range
Dim LastRow As Long
Dim LRow As Long
Dim Copy As Range
Set oWs = ActiveWorkbook.Worksheets("Sheet1")
LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
lEndNum = oWs.Range("A2").End(xlDown).Row
Set Copy = oWs.Range("A2" & LRow)
Set rSearchRng = oWs.Range("A2:A" & CStr(lEndNum))
Set loc = rSearchRng.Cells.Find(Range("O2").Value)
If Not loc Is Nothing Then
Do Until loc Is Nothing
loc.Select
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 12)).Select
Selection.Copy
Sheets("Sheet2").Select
LastRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Range("A" & LastRow).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Sheets("Sheet1").Select
Application.CutCopyMode = False
Set loc = rSearchRng.FindNext(loc)
Loop
End If
Set loc = Nothing
MsgBox "Complete"
End Sub
Thanks in advance
Aydos
Here is a quote from the help text on FindNext
When the search reaches the end of the specified search range, it wraps around to the beginning of the range. To stop a search when this wraparound occurs, save the address of the first found cell, and then test each successive found-cell address against this saved address.
I think that applies to your situation
it's because Find() method keeps on going inside the range
so you have to stop it when it wraps back to the first found cell by monitoring its address, as follows (along with some other refactoring):
Sub Macro()
Dim oWs As Worksheet
Dim rSearchRng As Range
Dim lEndNum As Long
Dim vFindVar As Variant
Dim loc As Range
Dim LastRow As Long
Dim LRow As Long
Dim Copy As Range
Set oWs = ActiveWorkbook.Worksheets("Sheet1")
LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
lEndNum = oWs.Range("A2").End(xlDown).Row
Set Copy = oWs.Range("A2" & LRow)
Set rSearchRng = oWs.Range("A2:A" & CStr(lEndNum))
Dim locFirstAddress As String
Set loc = rSearchRng.Cells.Find(Range("O2").value)
If Not loc Is Nothing Then
locFirstAddress = loc.Address
Do
Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(0, 12)).Copy
With Sheets("Sheet2")
.Range("A" & .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Paste
End With
Application.CutCopyMode = False
Set loc = rSearchRng.FindNext(loc)
Loop While loc.Address <> locFirstAddress
End If
Set loc = Nothing
MsgBox "Complete"
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
I'm trying to copy a variable range from one book (Book1) to the end of a variable range of the another book (book2). I'm interested only in values of the variable range in the book 1 and this is the problem. So I need to find the last row of values (not formulas). On this forum I found several options but none of them works in my case. Here is what I got (Please see the second part of the code "Copy Detail USHB"-'Select cells to copy):
''''''Copy Detail by Vendor''''''
'Last cell in column
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Detail by Vendor")
With WS
Set LastCell = .Cells(.Rows.Count, "B").End(xlUp)
LastCellRowNumber = LastCell.Row + 1
End With
Dim wb As Workbook, wb2 As Workbook
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
Workbooks.Open Filename:= _
"Book2.xlsm"
'Set selectedworkbook
Set wb2 = ActiveWorkbook
'Select cells to copy
Sheets("By Vendor").Select
Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
'Go back to original workbook you want to paste into
wb.Activate
Sheets("Detail by Vendor").Select
'Paste starting at the last empty row
wb.Worksheets("Detail by Vendor").Range("B" & LastCellRowNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
'''''Copy Detail USHB'''''
'Last cell in column
Set WS = Worksheets("Detail USHB")
With WS
Set LastCell = .Cells(.Rows.Count, "B").End(xlUp)
LastCellRowNumber = LastCell.Row + 1
End With
'Activate the target workbook
wb2.Activate
'Select cells to copy
Sheets("Detail USHB").Select
Dim jLastRow As Long
jLastRow = Columns("B").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Range(Selection, ActiveCell.SpecialCells(xlLastRow).Select
Selection.Copy
'Go back to original workbook you want to paste into
wb.Activate
Sheets("Detail USHB").Select
'Paste starting at the last empty row
wb.Worksheets("Detail USHB").Range("B" & LastCellRowNumber).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Following your comments, I believe you are trying to do the following:
'...
'''''Copy Detail USHB'''''
Dim D As Range
Dim S As Range
With wb2.Worksheets("Detail USHB")
'Locate the last non-blank value in source range
LastRow = .Range("B:B").Find(What:="*", _
LookIn:=xlValues, _
SearchDirection:=xlPrevious).Row
'Set range
Set S = .Range("B2:B" & LastRow)
End With
With wb.Worksheets("Detail USHB")
'Find last used cell in destination range
Set D = .Range("B" & .Rows.Count).End(xlUp)
'Offset to next row, and resize appropriately
Set D = D.Offset(1, 0).Resize(LastRow - 1, 1)
End With
'Copy values
D.Value = S.Value
End Sub
for the code below, if a search comes up empty based on Criteria1:="Ship", then there is nothing to copy, and the code stops at Set rngCopy = Intersect(rngCopy, .Range("A1:H" & lRow), .Range("A1:H" & lRow).Offset(1)).SpecialCells(xlCellTypeVisible), how can I get rid of this bug? Additionally, I want the whole table to show even if no data meets the criteria. I have the line Worksheets("Efficiency").ShowAllData but this is under the assumption the code runs all the way.
Thanks,
Sub ImportShipper()
Dim wsEff As Worksheet
Dim wsShip As Worksheet
Dim wsFirst As Worksheet
Set wsEff = Worksheets("Efficiency")
Set wsFirst = Worksheets("1")
Set wsShip = ActiveSheet
wsShip.Name = wsFirst.Range("B34").Value
With wsEff
Dim lRow As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:H" & lRow).AutoFilter Field:=2, Criteria1:="Ship"
Dim rngCopy As Range
'All Columns A:H
Set rngCopy = .Columns("A:H")
'filtered rows, not including header row - assumes row 1 is headers
Set rngCopy = Intersect(rngCopy, .Range("A1:H" & lRow), .Range("A1:H" & lRow).Offset(1)).SpecialCells(xlCellTypeVisible)
rngCopy.Copy
End With
wsShip.Range("A4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Efficiency").ShowAllData
End Sub
you could go like this
Option Explicit
Sub ImportShipper()
Dim wsEff As Worksheet
Dim wsShip As Worksheet
Dim wsFirst As Worksheet
Set wsEff = Worksheets("Efficiency")
Set wsFirst = Worksheets("1")
Set wsShip = ActiveSheet
wsShip.Name = wsFirst.Range("B34").value
With wsEff
Dim lRow As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:H" & lRow)
.AutoFilter Field:=2, Criteria1:="Ship"
With .Offset(1).Resize(.Rows.Count - 1)
If Application.WorksheetFunction.Subtotal(103, .Columns(2)) > 0 Then
.SpecialCells(xlCellTypeVisible).Copy
wsShip.Range("A4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
End With
End With
End With
Worksheets("Efficiency").ShowAllData
End Sub
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