I'm trying to get a unique range pfrom Sheet A (pivot summarizing my data on an irrelevant master sheet) to paste on another sheet Sheet B (New Blank sheet). Below is my code for this. I get a runtime error "AdvancedFilter method of Range class failed". I have literally tried everything for hours and have no idea what else to do.
Public Function FindRow(ByVal sht As Worksheet, ByVal r As Long, ByVal c As Long, ByVal Match As Variant) As Long
Do While Cells(r, c) <> Match
r = r + 1
Loop
FindRow = r
End Function
Sub ExtractFromPivot()
Dim PivotSheet As Worksheet
Dim RandomSheet As Worksheet
Dim Newsheet As Worksheet
Dim Newbook As Workbook
Dim Fundname As String
Dim FilePath As String
Dim Copyrange As String
Dim fr As Long
Dim lr As Long
Set RandomSheet = ThisWorkbook.Worksheets.Add
Set PivotSheet = ThisWorkbook.Worksheets("Extract Pivot")
'Clears all filters on 'Name' (believe me I tried .clearallfilters
With ThisWorkbook.SlicerCaches("Slicer_Client_Name")
.SlicerItems("a").Selected = True
.SlicerItems("b").Selected = True
.SlicerItems("c").Selected = True
End With
lr = FindRow(PivotSheet, 30, 1, "")
Let Copyrange = "A31" & ":" & "A" & lr
PivotSheet.Range(Copyrange).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=RandomSheet.Cells(1, 1), Unique:=True
Related
I have this program to copy an entire row to another sheet within the same workbook depending on if the person's name (pulled from let's say Sheet 1) is found to be on another spreadsheet (sheet 2).
The department is then used (From sheet 1) to place the name that is found on sheet 2 on the department specific sheet.
It is only printing the first instance of the condition and nothing else on every department page.
Main:
Sub copy2Sheets()
Dim table As Worksheet: Set table = Worksheets("Table")
Dim N As Long
N = 117
Dim i As Long
Dim tempDep As String
Dim tempName As String
tempDep = table.Cells(1, "B").value
tempName = table.Cells(1, "A").value
copyPaste tempName, Worksheets(Trim(tempDep))
'Loop Case:
For i = 2 To N - 1
tempDep = table.Cells(i, "B").value
tempName = table.Cells(i, "A").value
copyPaste tempName, Worksheets(Trim(tempDep))
Next i
End Sub
PasteFunction:
Sub copyPaste(Name As String, place As Worksheet)
'Worksheet Variables
Dim wsSource As Worksheet
Dim targSource As Worksheet: Set targSource = place
'CurrentLast Row As Long
Dim iTargetRow As Long
'Which Cell was Found
Dim FoundCell As Range
Dim copyTo As Long: copyTo = targSource.Cells(Rows.count, "A").End(xlUp).Row
'Assign Variables
Set wsSource = Worksheets("Last Month's BBS SafeUnsafe by ")
Set FoundCell = check(Name)
If Not FoundCell Is Nothing Then
copyTo = copyTo + 1
wsSource.Cells(FoundCell.Row).EntireRow.Copy targSource.Range("A" & copyTo)
End If
End Sub
Check function:
Public Function check(Name As String) As Range
Dim Rng As Range
Dim ws As Worksheet: Set ws = Worksheets("Last Month's BBS SafeUnsafe by ")
If Trim(Name) <> "" Then
Set Rng = ws.Range("C:C").Find(Name)
If Not Rng Is Nothing Then
Set check = Rng
End If
End If
End Function
Example Excel Sheets:
"Sheet 1"
Sheet 2
In the images, only the first entry from sheet 2 is being copied into every sheet, rather than every entry being pasted into their respective sheets.
Splitting up your code like that makes it more difficult to follow - try only using one method:
Sub copy2Sheets()
Const N As Long = 116 'use const for fixed values
Dim wsTable As Worksheet, wsBBS As Worksheet, i As Long
Dim wsDest As Worksheet, f As Range, tempDep As String, tempName As String
Set wsTable = ThisWorkbook.Worksheets("Table")
Set wsBBS = ThisWorkbook.Worksheets("Last Month's BBS SafeUnsafe by ")
For i = 1 To N
tempDep = Trim(wsTable.Cells(i, "B").Value)
tempName = Trim(wsTable.Cells(i, "A").Value)
If Len(tempName) > 0 Then
Set wsDest = ThisWorkbook.Worksheets(tempDep)
Set f = wsBBS.Columns("C").Find(what:=tempName, lookat:=xlWhole)
If Not f Is Nothing Then
f.EntireRow.Copy wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
End If
Next i
End Sub
I am having some issues with the code I have written below, object is of code is to copy data from columns A:E and G:U in one workbook to another without overwriting existing data.
File Path of source file is written in cell H13 and destination worksheet is written in cell H6, this is done because the source file and destination worksheet vary.
Sub Dataprep2()
Application.ScreenUpdating = False
Dim ws As String
Dim wb As Workbook
Dim cwb As String
Set wb = Workbooks.Open(Range("H13").Value)
ws = ThisWorkbook.Sheets("Macro Control").Range("H6").Value
''' CODE ERRORS ON BELOW LINE '''
wb.Worksheets("MAL Corrections").Range("A:E").CopyDestination:=ThisWorkbook.Worksheets(ws).Range("A:E").End(xlUp).Row
wb.Close True
Application.ScreenUpdating = True
End Sub
Complicating a Consolidation
Carefully adjust the values in the constants (first) section of the
code in the Sub.
You only run the Sub.
The Functions are being called by the Sub.
The Code
Option Explicit
Sub Dataprep2()
' Source
Const BookAddress As String = "H13"
Const SourceName As String = "MAL Corrections"
Const SourceFirstRow As Long = 2
' Target
Const DataName As String = "Macro Control"
Const TargetAddress As String = "H6"
' Source/Target
Const STByColumn As Long = 1
Dim STColumns As Variant
STColumns = Array("A:E", "G:U")
' Define Data Worksheet.
Dim wsD As Worksheet
Set wsD = ThisWorkbook.Worksheets(DataName)
' Define Source Worksheet.
Dim wbS As Workbook: Set wbS = Workbooks.Open(wsD.Range(BookAddress).Value)
Dim wsS As Worksheet: Set wsS = wbS.Worksheets(SourceName)
' Define Target Worksheet
Dim wsT As Worksheet
Set wsT = ThisWorkbook.Worksheets(wsD.Range(TargetAddress).Value)
' Write values of ranges to arrays.
Dim Source() As Variant, i As Long
ReDim Source(UBound(STColumns))
For i = 0 To UBound(Source)
Source(i) = getColumns(wsS, STColumns(i), STByColumn, SourceFirstRow)
Next i
' Calculate first empty row in target sheet.
Dim TargetFirstRow As Long
TargetFirstRow = getFirstEmptyRow(wsT, wsT.Columns(STByColumn).Column)
If TargetFirstRow = 0 Then Exit Sub
' Write values of arrays to target sheet.
Dim rng As Range
For i = 0 To UBound(Source)
Set rng = Intersect(wsT.Columns(STColumns(i)), wsT.Rows(TargetFirstRow))
rng.Resize(UBound(Source(i)), UBound(Source(i), 2)).Value = Source(i)
Next i
wbS.Close False
End Sub
Function getColumns(Sheet As Worksheet, ByVal sourceColumns As String, _
Optional ByVal ByColumn As Long = 1, _
Optional ByVal FirstRow As Long = 1) As Variant
Dim rng As Range, LastRow As Long
Set rng = Sheet.Columns(sourceColumns)
If ByColumn > rng.Columns.Count Then Exit Function
Set rng = Sheet.Columns(sourceColumns).Columns(ByColumn) _
.Find("*", , xlFormulas, , , xlPrevious)
If rng Is Nothing Then Exit Function
If rng.Row < FirstRow Then Exit Function
getColumns = Intersect(Sheet.Columns(sourceColumns), Sheet.Rows(FirstRow)) _
.Resize(rng.Row - FirstRow + 1)
End Function
Function getFirstEmptyRow(Sheet As Worksheet, ByVal SourceColumn As Variant)
Dim rng As Range
Set rng = Sheet.Columns(SourceColumn) _
.Find("*", , xlFormulas, , , xlPrevious)
If rng Is Nothing Then getFirstEmptyRow = 1: Exit Function
If rng.Row = Sheet.Rows.Count Then Exit Function
getFirstEmptyRow = rng.Row + 1
End Function
Hi I previously posted about some difficulties in running a loop. I made some adjustments to it. I am wondering what is wrong.
Sub Macro1()
Dim DVariable As Date
Dim RngFind As Range
Dim MonthNo, YearNo As Integer
Dim StartDate, EndDate As Date
Dim PasteCell As Range
Dim M As Long, i As Long
Dim ws As Worksheet
Dim ws1 As Worksheet
Application.DisplayAlerts = False
Sheets("By Trader").Select
Set ws1 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws1.Name = "NEW"
Set ws = Sheets("Macro")
Sheets("Macro").Select
M = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For M = 2 To M
With Sheets("By Trader")
'loop column N until last cell with value (not entire column)
For Each Cell In .Range("N1:N" & .Cells(.Rows.Count, "N").End(xlUp).Row)
If Cell.Value = M Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets("NEW").Rows(Cell.Row)
End If
Next M
Application.DisplayAlerts = True
End Sub
I am aiming to extract the entire row if there is a match in values to another sheet.
You are missing a Next Cell and an End With
Sub Macro1()
Dim DVariable As Date
Dim RngFind As Range
' You need to declare every variable in the line. If you don't it will be declared as a variant instead of just your last declaration
Dim MonthNo As Integer, YearNo As Integer
Dim StartDate, EndDate As Date
Dim PasteCell As Range
Dim M As Long, i As Long, NoRow As Long
Dim ws As Worksheet
Dim ws1 As Worksheet
Application.DisplayAlerts = False
Sheets("By Trader").Select
Set ws1 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws1.Name = "NEW"
Set ws = Sheets("Macro")
ws.Select
' Changed variable to prevent erroneous errors
NoRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For M = 2 To NoRow
With Sheets("By Trader")
'loop column N until last cell with value (not entire column)
For Each Cell In .Range("N1:N" & .Cells(.Rows.Count, "N").End(xlUp).Row)
If Cell.Value = M Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets("NEW").Rows(Cell.Row)
End If
' Missing the next two lines
Next Cell
End With
Next M
Application.DisplayAlerts = True
End Sub
I have written the following code which should, match column headings in destination workbook, search for the same column heading in the source workbook (worksheet), fetch all the data under that particular column till the end of the row and copy it under the same column heading in the destination workbook (worksheet).
This task should be performed till all the columns in the destination workbook's worksheet gets filled.
Sub LPN()
Dim CurrentWS As Worksheet
Set CurrentWS = ActiveSheet
ActiveWorkbook.Sheets("controls").Select
'I have made a sheet in the main workbook(Rates EMEA CDS PT+FVA.v1.25 Apr 2016.i1.xlsm)
' known as **controls** , in this sheet I have specified the path of the
' workbook(worksheet) that has to be opened and from where the data has to be copied.
'The name of the cell where the path has been mentioned I named it as GPL
Set master = ActiveWorkbook
GPL = Range("GPL").Value
Workbooks.Open Filename:=GPL
Set GPLfile = ActiveWorkbook
'Open the particular workbook with specified worksheet having .xlsx extension
Dim SourceWS As Worksheet
Set SourceWS = ActiveWorkbook.Worksheets("PNL Attribution")
Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
Dim SourceCell As Range
Workbooks("Rates EMEA CDS PT+FVA.v1.25 Apr 2016.i1.xlsm").Activate
Dim TargetWS As Worksheet
Set TargetWS = Worksheets("PNL Attribution")
Dim TargetHeader As Range
'The code will look for all the column headings in the source workbook
' match it with the headings in the target workbook(worksheet) which are not in order.
Set TargetHeader = TargetWS.Range("A10:ZZ10")
Dim RealLastRow As Long
Dim SourceCol As Integer
SourceWS.Activate
For Each Cell In TargetHeader
If Cell.Value <> "" Then
Set SourceCell = Rows(SourceHeaderRow).Find _
(Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
SourceCol = SourceCell.Column
RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If RealLastRow > SourceHeaderRow Then
Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
SourceCol)).copy
TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
End If
End If
End If
Next
CurrentWS.Activate
End Sub
Can you adapt it to your task?
Sub Cols_Value_Add_test()
Set shSour = Worksheets("1")
Set shDest = Worksheets("2")
Dim rngSour As Range, rngDest As Range
Set rngSour = shSour.Cells(3, 2)
Set rngDest = shDest.Cells(3, 3)
Dest_Row = rngDest.Row + rngDest.CurrentRegion.Rows.Count
Cols_Value_Add rngSour, rngDest
End Sub
Sub Cols_Value_Add(rngSour As Range, _
rngDest As Range)
Dim rngDest_Col As Long, rngDest_Col_Max As Long
Dim shSour_Col As Long
rngDest_Col_Max = rngDest.CurrentRegion.Columns.Count
For rngDest_Col = 1 To rngDest_Col_Max
shSour_Col = shSour_Col_Find(rngDest, rngDest_Col)
If shSour_Col > 0 Then _
CopyPaste rngSour, shSour_Col, rngDest, rngDest_Col
Next
End Sub
Sub CopyPaste(rngSour As Range, _
shSour_Col As Long, _
rngDest As Range, _
rngDest_Col As Long)
Dim Sour_Row_Max As Long
Sour_Row_Max = rngSour.CurrentRegion.Row + rngSour.CurrentRegion.Rows.Count - 1
With shSour
Set rngSour = .Range(.Cells(rngSour.Row, shSour_Col), _
.Cells(Sour_Row_Max, shSour_Col))
End With
rngSour.Copy
rngDest_Col = rngDest.Row + rngDest_Col - 1
shDest.Cells(Dest_Row, rngDest_Col).PasteSpecial _
Paste:=xlPasteValues
End Sub
Function shSour_Col_Find(rngDest As Range, _
rngDest_Col As Long) _
As Long
Dim sHeader As String, rng As Range
sHeader = rngDest.Cells(1, rngDest_Col).Value
Set rng = shSour.Cells.Find(sHeader, , , xlWhole)
If Not rng Is Nothing Then _
shSour_Col_Find = rng.Column
End Function
I am trying to populate a range of cells dynamically using VLookup. My Active Sheet is where I am trying to insert value of cells from another worksheet in same workbook. For the second parameter of VLookup I am trying to use the variable dataRng which gets me the entire range of values to lookup in my source sheet (srcSheet). All the code works as expected except the VLookup returns #NAME? and its the dataRng variable which seems to be the issue. Any suggestions?
Sub VlookUpCreateDate()
Dim srcSheetName As String
Dim currSheetName As String
Dim currlastRow As Long
Dim currlastCol As Long
Dim srcLastRow As Long
Dim srcLastCol As Long
Dim srcFirstRow As Long
Dim srcSheet As Worksheet
Dim firstVar As String
Dim refRng As Range, ref As Range, dataRng As Range
srcSheetName = ActiveWorkbook.Worksheets(1).Name
Set srcSheet = ActiveWorkbook.Sheets(srcSheetName)
'Get Last Row and Column
With ActiveSheet
currlastRow = ActiveSheet.UsedRange.Rows.Count
currlastCol = ActiveSheet.UsedRange.Columns.Count
End With
With srcSheet
srcFirstRow = 2
srcLastRow = srcSheet.UsedRange.Rows.Count
srcLastCol = srcSheet.UsedRange.Columns.Count
End With
Set dataRng = srcSheet.Range(srcSheet.Cells(srcFirstRow, srcLastCol), srcSheet.Cells(srcLastRow, srcLastCol))
For i = 2 To currlastRow
Cells(i, currlastCol + 1).Select
ConvertToLetter & "$" & srcLastRow
ActiveCell.Formula = "=VLOOKUP(A2,dataRng,4,False)"
Next i
End Sub
Here is a simple example that should work for you, using the dataRng address in the formula
Dim dataRng As Range, s
Set dataRng = Range("AA1:AF7")
s = dataRng.Address
ActiveCell = "=VLOOKUP(A2," & s & ",4,0)"