I have two workbook 1. thisWB 2. newWB
Now i need to copy data from lastblank row + 1 of thisWB to newWB workbook and paste in lastblank row + 1.
I have put some codes like below but it do not work, could you suggest what is the problem with the below code
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim ws As Worksheet
Dim blankcell As Long
blankcell = Columns(1).Find("", LookIn:=xlValues, lookat:=xlWhole).Row
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Windows(thisWB).Sheets("BS All Entities").Rows(blankcell + 1 & ":" & LastRow).Copy Destination:=Windows(newWB).Sheets("BS All Entities").Cells(Rows.Count, "A").End(xlUp).Offset(2, 0)
Application.ScreenUpdating = True
Thank you for all your help in advance.
KR
Manoj
Try the following code:
Application.ScreenUpdating = False
Dim rngLastColumnOld As Long
Dim rngLastRowOld As Long
Dim rngTemp As Range
Dim rngFirstBlankOld As Range
Dim rngCopyFrom As Range
Dim rngFirstBlankNew As Range
With Windows(thisWB).Sheets("BS All Entities")
Set rngTemp = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
If rngTemp Is Nothing Then
rngLastColumnOld = 1
Else
rngLastColumnOld = rngTemp.Column
End If
rngLastRowOld = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set rngFirstBlankOld = .Range("A1").End(xlDown).Offset(1)
Set rngCopyFrom = .Range(rngFirstBlankOld, .Cells(rngLastRowOld, rngLastColumnOld))
End With
Set rngFirstBlankNew = Windows(newWB).Sheets("BS All Entities").Cells(Rows.Count, "A").End(xlUp).Offset(1).EntireRow
rngFirstBlankNew.Resize(rngCopyFrom.Rows.Count, rngCopyFrom.Columns.Count).Value = rngCopyFrom.Value
Application.ScreenUpdating = True
Go thru this link
http://www.mrexcel.com/forum/excel-questions/755467-using-visual-basic-applications-paste-data-multiple-sheets.html
only change is instead of same workbook sheets i am using different workbook sheets
Related
I'm new to this so please help me. I have a workbook with below three sheets-
Sheet1- Has 3 cloumns- A,B,C
Sheet2- Has One Column- A
**Ouput
If Value in a cell of Sheet1- Column B matches with value in any cell of Sheet2 Column A then copy that entire row and paste to next available blank row (starts from column A) of output sheet.
column B of sheet 2 can have duplicate cells and all the matched cells should go to next available row of output sheet.
**Sheet 1** **Sheet 2** **Output**
A B C A 3 Glen 28
1 Jen 26 Glen 1 Jen 26
2 Ben 24 Jen 4 Jen 18
3 Glen 28
4 Jen 18
I tried below. Not sure how good it is-
Sub Test()
Set objwork1 = ActiveWorkbook ' Workbooks("Search WR")
Set obj1 = objwork1.Worksheets("Header")
Set obj2 = objwork1.Worksheets("XML1")
Set obj3 = objwork1.Worksheets("VC")
Set obj4 = objwork1.Worksheets("Output")
i = 2
j = 2
Do Until (obj3.Cells(j, 1)) = ""
If obj2.Cells(i, 2) = obj3.Cells(j, 1) Then
Set sourceColumn = obj2.Rows(i)
Set targetColumn = obj4.Rows(j)
sourceColumn.Copy Destination:=targetColumn
Else
i = i + 1
End If
j = j + 1
Loop
End Sub
Tried below as well-
Sub Check()
Set objwork1 = ActiveWorkbook ' Workbooks("Search WR")
Set obj1 = objwork1.Worksheets("Header")
Set obj2 = objwork1.Worksheets("XML1")
Set obj3 = objwork1.Worksheets("VC")
Set obj4 = objwork1.Worksheets("Output")
Dim LR As Long, i As Long, j As Long
j = 2
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
For j = 2 To LR
obj3.Select
If obj3.Range("A" & i).value = obj2.Range("B" & j).value Then
Rows(j).Select
Selection.Copy
obj4.Select
obj4.Range("A1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
obj3.Select
End If
Next j
Next i
End Sub
Another approach
Copy all rows from Sheet1 to Output
Sort Output by custom list order (Sheet2)
Remove all rows in Output not in list (beginning in the last row)
So …
Option Explicit
Public Sub CopyListedRowsAndSortByListOrder()
Dim wsSrc As Worksheet
Set wsSrc = Worksheets("Sheet1")
Dim lRowSrc As Long
lRowSrc = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
Dim wsList As Worksheet
Set wsList = Worksheets("Sheet2")
Dim lRowList As Long
lRowList = wsList.Cells(wsList.Rows.Count, "A").End(xlUp).Row
Dim wsDest As Worksheet
Set wsDest = Worksheets("Output")
'Copy all rows
wsSrc.Range("A1:C" & lRowSrc).Copy wsDest.Range("A1")
Dim lRowDest As Long
lRowDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row
'sort Output column B by list in Sheet2
With wsDest.Sort
.SortFields.Add Key:=wsDest.Range("B2:B" & lRowDest), _
SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
Join(WorksheetFunction.Transpose(wsList.Range("A2:A" & lRowList).Value), ","), DataOption:=xlSortNormal
.SetRange Range("A1:C" & lRowDest)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'remove all rows not in list (backwards)
Dim i As Long
For i = lRowDest To 2 Step -1
If Not IsError(Application.Match(wsDest.Cells(i, "B"), wsList.Range("A2:A" & lRowList))) Then Exit For
Next i
wsDest.Range(i + 1 & ":" & lRowDest).Delete xlShiftUp
End Sub
Something like (assumes you are copying from first sheet. That wasn't clear).
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
Set ws3 = wb.Worksheets("Output")
Dim currCell As Range, unionRng As Range
'Sheet1 column B matches sheet2 column A
With ws1
For Each currCell In Intersect(.Range("B:B"), .UsedRange)
If FoundInColumn(ws2, currCell, 1) Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, currCell.EntireRow)
Else
Set unionRng = currCell.EntireRow
End If
End If
Next currCell
End With
If Not unionRng Is Nothing Then unionRng.Copy ws3.Range("A" & IIf(GetLastRow(ws3, 1) = 1, 1, GetLastRow(ws3, 1)))
End Sub
Public Function FoundInColumn(ByVal ws As Worksheet, ByVal findString As String, ByVal columnNo As Long) As Boolean
Dim foundCell As Range
Set foundCell = ws.Columns(columnNo).Find(What:=findString, After:=ws.Cells(1, columnNo), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not foundCell Is Nothing Then FoundInColumn = True
End Function
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
If it is everything from sheet2 that matches to copy then:
Option Explicit
Sub test2()
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Sheet1")
Set ws2 = wb.Worksheets("Sheet2")
Set ws3 = wb.Worksheets("Output")
Dim currCell As Range, unionRng As Range
Dim dict As Dictionary 'tools > references > ms scripting runtime
Set dict = New Dictionary
'Sheet1 column B matches sheet2 column A
With ws1
For Each currCell In Intersect(.Range("B:B"), .UsedRange)
If Not dict.Exists(currCell.Value) And Not IsEmpty(currCell) Then
dict.Add currCell.Value, currCell.Value
Dim tempRng As Range
Set tempRng = GatherRanges(currCell.Value, Intersect(ws2.Range("A:A"), ws2.UsedRange))
If Not tempRng Is Nothing Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, tempRng)
Else
Set unionRng = tempRng
End If
End If
End If
Next currCell
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Copy ws3.Range("A" & IIf(GetLastRow2(ws3, 1) = 1, 1, GetLastRow2(ws3, 1)))
End Sub
Public Function GatherRanges(ByVal findString As String, ByVal searchRng As Range) As Range
Dim foundCell As Range
Dim gatheredRange As Range
With searchRng
Set foundCell = searchRng.Find(findString)
Set gatheredRange = foundCell
Dim currMatch As Long
For currMatch = 1 To WorksheetFunction.CountIf(.Cells, findString)
Set foundCell = .Find(What:=findString, After:=foundCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not gatheredRange Is Nothing Then
Set gatheredRange = Union(gatheredRange, foundCell)
Else
Set gatheredRange = foundCell
End If
Next currMatch
End With
Set GatherRanges = gatheredRange
End Function
Public Function GetLastRow2(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow2 = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
you could try this
Sub Test()
Dim filts As Variant
With Worksheets("Sheet2")
filts = Application.Transpose(.Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Value)
End With
With Worksheets("Sheet1").Range("A1").CurrentRegion
.AutoFilter Field:=2, Criteria1:=filts, Operator:=xlFilterValues
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy Worksheets("Output").Range("A1")
.Parent.AutoFilterMode = False
End With
End Sub
Beginner VBA scripter here. How can I fix my code so that it will search thru Sheet1 for the string array in strSearch and copy those rows into Sheet2?
Also, how can I extend the code to be able to search for a different string array and copy it into another worksheet?
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim lastRow As Long
Dim strSearch As Variant
Dim i As Integer
Set ws1 = Worksheets("Sheet1")
With ws1
.AutoFilterMode = False
lRow = .Range("J" & .Rows.Count).End(xlUp).Row
With .Range("J1:J" & lRow)
On Error Resume Next
strSearch = Array("John","Jim")
.AutoFilter Field:=1, Criteria1:=strSearch
Set copyFrom = .Offset(0).SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
End With
Set ws2 = Worksheets("Sheet2")
With ws2
On Error Resume Next
lastRow = ws2.Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
Set Rng = copyFrom.SpecialCells(xlCellTypeConstants)
Rng.Copy .Cells(lastRow + 1, "C")
copyFrom.Delete
On Error GoTo 0
End With
.AutoFilterMode = False
You could iterate through the lines and the array:
Option Explicit
Dim firstRowWs1 As Long
Dim lastRowWs1 As Long
Dim lastRowWs2 As Long
Dim searchColumnWs1 As Integer
Dim i As Integer
Dim check As Variant
Dim strSearch As Variant
Sub test()
lastRowWs1 = ws1.UsedRange.Rows.Count
lastRowWs2 = ws2.UsedRange.Rows.Count
firstRowWs1 = 2
searchColumnWs1 = 1
strSearch = Array("John", "Jim")
For i = firstRowWs1 To lastRowWs1
For Each check In strSearch
If check = ws1.Cells(i, searchColumnWs1).Value Then
ws1.Rows(i).Copy (ws2.Rows(lastRowWs2 + 1))
lastRowWs2 = lastRowWs2 + 1
ws1.Rows(i).Delete shift:=xlUp
i = i - 1
Exit For
End If
Next check
Next i
End Sub
Dim strsearchlocation as integer
strSearchLocation = Sheet1.Cells.Find(what:= strSearch, After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).row
Sheet1.Rows(strSearchLocation).Copy
Finds and copies the row of strSearch
I'm trying to open a workbook and then select and copy a range from A7 to L7 until the last row of information (in a downward direction). I think the variable isn't properly defined. Any help?
Sub Subtotals()
Dim DT As Workbook
Dim lRowDT As Integer
Set DT = Workbooks.Open("C:\Users\ricardo\Desktop\Data Fuel.xls")
lRowDT = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Workbooks("Data Fuel.xls").Worksheets("Data").Activate
Worksheets("Data").Range("A7:L" & lRowDT).Copy
End sub
If there is not data over colums L , then this code is suitable.
Sub Subtotals()
Dim DT As Workbook
Dim lRowDT As Integer
Dim Ws As Worksheet
Dim rngDB As Range, r As Long, c As Long
Set DT = Workbooks.Open("C:\Users\ricardo\Desktop\Data Fuel.xls")
'lRowDT = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Set Ws = Workbooks("Data Fuel.xls").Worksheets("Data")
With Ws
r = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
c = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set rngDB = .Range("a7", .Cells(r, "L"))
End With
rngDB.Copy
End Sub
I'm working on a code that I've pieced together, but what I'm finding is that after the "used" range is found (I'm trying not to use .usedrange due to reliability) is that the SourceData:= is expecting a string (I think).
Is there a way to pass through the range from the Data sheet to the pivot table data range? I tried appending RealUsedRange.Address, but that was no luck either.
Sub UpdatePivotRange()
Dim Rng1 As Range
Dim oWB As Workbook
Dim oWS As Worksheet
Dim DataSheet As Worksheet
Dim oPT As PivotTable
Set oWB = ThisWorkbook
Set DataSheet = oWB.Sheets("Data")
Set Rng1 = RealUsedRange
If Rng1 Is Nothing Then
MsgBox "There is no used range, the worksheet is empty."
Else
For Each oWS In oWB.Worksheets
For Each oPT In oWS.PivotTables
'ERRROR BEGINS HERE #####
oPT.ChangePivotCache _
oWB.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=Rng1)
'ERROR ENDS HERE #####
Next oPT
Next oWS
End If
End Sub
Public Function RealUsedRange() As Range
Dim FirstRow As Long
Dim LastRow As Long
Dim FirstColumn As Integer
Dim LastColumn As Integer
Dim DataSheet As Worksheet
Dim oWB As Workbook
On Error Resume Next
Set oWB = ThisWorkbook
Set DataSheet = oWB.Sheets("Data")
With DataSheet
FirstRow = DataSheet.Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
FirstColumn = DataSheet.Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
LastRow = DataSheet.Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = DataSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set RealUsedRange = Range(Cells(FirstRow, FirstColumn), Cells(LastRow, LastColumn))
End With
MsgBox "The range is" & RealUsedRange.Address
On Error GoTo 0
End Function
I was able to amend the errored line by adding:
oPT.ChangePivotCache _
oWB.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Data!" & Rng1.Address(ReferenceStyle:=xlR1C1))
Hope this helps anyone looking in the future.
I am attempting to consolidate some data into a specific excel template I have created. My data is titled as PAxxx.xx where x could be any number between 0-9. Is there a way I can search through my current workbook for that specific title "PAxxx.xx" and populate it into my created template field.
I current have this search function in VBA:
Sub CopyPasteCellData()
Dim FirstAddress As String
Dim searchTerms As Variant
Dim Rcount As Long
Dim I As Long
Dim Rng As Range
Dim currentWorkbook As Workbook
Dim newWorkbook As Workbook
Dim currentWorksheet As Worksheet
Dim newWorksheet As Worksheet
Set currentWorkbook = Workbooks("LVX Release 2015 (2).xlsm")
Set currentWorksheet = currentWorkbook.Sheets("PA5179.01")
Set newWorkbook = Workbooks("Test.xlsx")
Set newWorksheet = newWorkbook.Sheets("Sheet1")
'newWorksheet.Range("C2").Value = currentWorksheet.Range("A1").Value
searchTerms = Array("PA")
With currentWorksheet.UsedRange
Rcount = 0
For I = LBound(searchTerms) To UBound(searchTerms)
Set Rng = .Find(What:=searchTerms(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1
newWorksheet.Range("A" & Rcount).Value = Rng.Value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End Sub
Just not sure how to search the sheet for all data sets PAxxx.xx.
Thanks in advance :)
Here is a basic principle how to loop through all the sheets and find for a PAxxx.xx -> read instructions of Like operator if you need to change the validation ->
Sub LoopTroughWorkSheetsAndFindPA()
Dim wb As Workbook: Set wb = ThisWorkbook 'anyreference of a workbook you want
Dim ws As Worksheet
For Each ws In wb.Worksheets
If ws.Name Like "PA###.##" Then
'do some operations here for example ->
Debug.Print ws.Name
End If
Next
End Sub