I have a problem with the following vba script.
I want to copy some cells from one sheet to another.
The first sheet is selected based its name. The sheet where i want to paste the cells is selected based on cell B1 in the first sheet.
I am using the following code:
Dim ws as Worksheet
Dim LR3 as Long
Dim LR4 as Long
Dim LR5 as Long
Dim ws3 as Worksheet
For Each ws In ActiveWorkbook.Worksheets
If Not ws.Name Like "BC-*" Then
LR3 = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("E" & LR3 + 1).Formula = "=SUM(E4:E" & LR3 & ")"
Dim i As Long, n As Long
n = ws.Cells(Rows.Count, 1).End(xlUp).Row
With ws.Range("S1")
.Formula = "=myJoin(A4:A" & n & ","""")"
.Value = .Value
End With
LR4 = ws.Cells(Rows.Count, 6).End(xlUp).Row
ws.Range("F4:F" & LR4).Copy
ws.Range("M4:M" & LR4).PasteSpecial Paste:=xlPasteValues
ws.Range("M4:M" & LR4).RemoveDuplicates Columns:=1, Header:=xlNo
LR5 = ws.Cells(Rows.Count, 13).End(xlUp).Row
ws.Range("M4:M" & LR4).Cut
Set ws3 = ws.Range("B1").Value
ws3.Range("A30").PasteSpecial xlPasteValues
You need to use:
Set ws3 = ActiveWorkbook.Worksheets(ws.Range("B1").Value)
for example. Adjust the workbook if required.
Related
I am copying data from two workbooks to another workbook.
The code written by me works and serves the purpose.
I am having difficulty getting the syntax for using the offset method to copy to next empty row after the first paste.
With wsdly
lrowdly = Cells(Rows.Count, 2).End(xlUp).Row
.Range("A2:O" & lrowdly).ClearContents
wsb.Range("A2:O" & lrowb).Copy .Range("A2")
End With
With wsdly
lrowdly2 = Cells(Rows.Count, 2).End(xlUp).Row
lrowdly3 = lrowdly2 + 1
wsn.Range("A2:O" & lrown).Copy .Range("A" & lrowdly3)
End With
Whole program.
Sub copy_bond_dat()
Dim wbb As Workbook
Dim wbn As Workbook
Dim wbdly As Workbook
Dim wsb As Worksheet
Dim wsn As Worksheet
Dim wsdly As Worksheet
Set wbb = Workbooks("BSE_BOND.xlsm")
Set wbn = Workbooks("NSE_BOND.xlsm")
Set wbdly = Workbooks("Dly_Debt_Trnx_2022_TMP.xlsx")
Set wsb = wbb.Worksheets("BSEDATA")
Set wsn = wbn.Worksheets("NSEDATA")
Set wsdly = wbdly.Worksheets("Dly_Debt_Trnx_2022_TMP")
Dim lrowb As Long
Dim lrown As Long
Dim lrowdly As Long
Dim lrowdly2 As Long
Dim lrowdly3 As Long
With wsb
lrowb = Cells(Rows.Count, 2).End(xlUp).Row
End With
With wsn
lrown = Cells(Rows.Count, 2).End(xlUp).Row
End With
With wsdly
lrowdly = Cells(Rows.Count, 2).End(xlUp).Row
.Range("A2:O" & lrowdly).ClearContents
wsb.Range("A2:O" & lrowb).Copy .Range("A2")
End With
With wsdly
lrowdly2 = Cells(Rows.Count, 2).End(xlUp).Row
lrowdly3 = lrowdly2 + 1
wsn.Range("A2:O" & lrown).Copy .Range("A" & lrowdly3)
End With
wbdly.Close
End Sub
Changing the mentioned code lines to following code lines problem gets resolved.
With wsdly
lrowdly = .Cells(Rows.Count, 2).End(xlUp).Row
.Range("A2:O" & lrowdly).ClearContents
wsb.Range("A2:O" & lrowb).Copy .Range("A2")
wsn.Range("A2:O" & lrown).Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End With
I would like to copy values from column "C" from Sheet1, which are not in Sheet2. As loop is too slow, I added vlookup marking with X missing rows. Then I do autofilter with values X and copy values from column C and paste it to bottom of file in column A. I would like to paste there deduplicated values. Is there way to deduplicate values before pasting to new sheet?
My code currently coping all values:
Sub Copy_Value()
Dim Con As Worksheet
Dim Des As Worksheet
Dim Test As Worksheet
Dim Lastcol As Integer
Dim Lastrow As Integer
Dim Lastrow2 As Integer
Dim i As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
Lastrow = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "C").End(xlUp).Row
Set Res = ThisWorkbook.Sheets("Sheet2")
Set Con = ThisWorkbook.Sheets("Sheet1")
Set copyRange = Con.Range("C2:C" & Lastrow)
Con.Range("L1").AutoFilter Field:=12, Criteria1:="X"
Lastrow2 = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
copyRange.SpecialCells(xlCellTypeVisible).Copy Res.Range("A" & Lastrow2 + 1)
End Sub
Thank you
RemoveDuplicates is a VBA function that works very fast, and may be a suitable solution for your particular case. Based on the logic of our current code (using an “X” in Col L on Sheet1 to filter) the code below achieves what you want.
Option Explicit
Sub Copy_Value()
Dim LastRow As Long, PasteRow As Long
Application.ScreenUpdating = False
LastRow = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
PasteRow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1
Sheet1.Columns(12).AutoFilter 1, "X"
Sheet1.Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy _
Sheet2.Cells(PasteRow, 1)
LastRow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
With Sheet2.Range("A" & PasteRow & ":A" & LastRow)
.RemoveDuplicates 1, xlNo '<~~ xlNo = no header
End With
Sheet1.AutoFilterMode = False
End Sub
I try to copy last entire row to another sheet but failed
with this method it"s only copying single cell to all the row
Dim lrow As Long
With Worksheets("101")
lrow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("B" & lrow - 1, "M" & lrow).Copy
Worksheets("EOM").Range("B4").PasteSpecial xlPasteAll
End With
with this code it gives error
Dim shRead As Worksheet
Set shRead = ThisWorkbook.Worksheets("101")
Dim lastRow As Long, lastCol As Long
lastRow = shRead.Cells(shRead.Rows.Count, 2).End(xlUp).Row
lastCol = shRead.Cells(lastRow, shRead.Columns.Count).End(xlToLeft).Column
With shRead
shRead.Range(lastRow, lastCol).Copy_
Worksheets("EOM").Range(B4, M4)
End With
error on
shRead.Range(lastRow, lastCol).Copy_
In place of your code
With shRead
shRead.Range(lastRow, lastCol).Copy_
Worksheets("EOM").Range(B4, M4)
End With
You have to put start and end cell for a range
With shRead
.Range(.Cells(lastRow, 1), .Cells(lastRow, lastCol)).Copy Worksheets("EOM").Range("B4")
End With
for the destination the cell reference should be in double quotes
EDIT
You can use a code similar to the below one; to get data from all worksheets a loop is needed, you can amend the code according to your requirements
Dim i As Integer
i = 4
For Each ws In ActiveWorkbook.Worksheets
With ws
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
lastCol = .Cells(lastRow, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(lastRow, 1), .Cells(lastRow, lastCol)).Copy Worksheets("EOM").Range("B" & i)
i = i + 1
End With
Next
I am currently trying to filter data and paste it into another sheet to a certain range but it is only posting the latest data row. How do I fix the code so that it selects all the rows with the code word and pastes it into the other sheet.
This is my code:
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long
lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Sheets("sheet1").Cells(i, 1) = "pp" Then
Sheets("sheet1").Range(Cells(i, 2), Cells(i, 5)).Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet5").Range("A11:A22")
End If
Next
End Sub
I think this is what you want.
Private Sub CommandButton1_Click()
Dim ws1 as Worksheet: Set ws1 = Thisworkbook.Sheets("Sheet1")
Dim ws2 as Worksheet: Set ws2 = Thisworkbook.Sheets("Sheet5")
Dim LRow1 As Long, LRow2 as Long, i As Long
LRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If ws1.Cells(i, 1) = "pp" Then
ws1.Range(Cells(i, 1), Cells(i, 5)).Copy
ws2.Range("A" & LRow + 1).PasteSpecial xlPasteValues
End If
Next
End Sub
Here is a more effecient method using a For Each loop and one instance of Copy/Paste instead of 1 iteration for every matched cell.
Option Explicit
Sub Copy()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim TargetRange As Range, TargetCell As Range, CopyRange As Range
Set TargetRange = ws1.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
For Each TargetCell In TargetRange
If TargetCell = "pp" Then
If CopyRange Is Nothing Then
Set CopyRange = TargetCell.Resize(1, 4)
Else
Set CopyRange = Union(CopyRange, TargetCell.Resize(1, 4))
End If
End If
Next TargetCell
CopyRange.Copy
ws2.Range("A" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Another method would be to apply a filter for your target value pp and then copy/paste visible cells.
I am trying to paste values from a bunch of tables into one long list. I have the tables spread across different sheets and the number of rows changes, but the columns do not. Then I am also trying to paste a string value that tells what sheet it came from, but having trouble with the active cell part of the code.
When I first tried it, it did not compile, hence why I came here, to figure out why it did not compile. Going back and forth with urdearboy, below, I was able to get the correct code working here.
I have the following:
sub copypaste()
Dim ws1 as worksheet
dim ws2 as worksheet
dim mas as worksheet
Set ws1 =ThisWorkbook.Sheets("Sheet1")
Set ws2=ThisWorkbook.Sheets("Sheet2")
Set mas=ThisWorkbook.Sheets("Master") 'where I create my list
For Each ws In Worksheets
If ws.Name <> mas.Name Then
LRow = mas.Range("A" & mas.Rows.Count).End(xlUp).Offset(1, 0).Row
wsLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A2:A" & wsLRow - 1).Copy
mas.Range("A" & LRow).PasteSpecial Paste:=xlPasteValues
ws.Range("B2:B" & wsLRow - 1).Copy
mas.Range("B" & LRow).PasteSpecial Paste:=xlPasteValues
mas.Range(mas.Cells(LRow, 4), mas.Cells(wsLRow + LRow - 2, 4)) = ws.Name 'I need my sheet value in the fourth column, not the third, but simply change the col coordinate in the Cells equation above
End If
Next ws
'In order to figure out the sheet name, I used the following:
Dim rng As Range
Set rng = mas.Range("D2", Range("D2").End(xlDown))
For Each Cell In rng
If Cell.Value = "Sheet 1" Then
Cell.Value = "S1"
ElseIf Cell.Value = "Sheet 2" Then
Cell.Value = "S2"
End If
Next Cell
end sub
This will loop through all sheets, with the exception of Master, and import the values on Column A to Master accompanied by the origin of the data (sheet name).
Option Explicit for good measure.
Option Explicit
Sub copypaste()
Dim mas As Worksheet: Set mas = ThisWorkbook.Sheets("Master")
Dim ws As Worksheet, LRow As Long, wsLRow As Long
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> mas.Name Then
LRow = mas.Range("A" & mas.Rows.Count).End(xlUp).Offset(1).Row
wsLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A2:A" & wsLRow).Copy mas.Range("A" & LRow)
mas.Range(mas.Cells(LRow, 2), mas.Cells(wsLRow + LRow - 2, 2)) = ws.Name
End If
Next ws
Application.ScreenUpdating = True
End Sub
To paste values change
ws.Range("A2:A" & wsLRow).Copy mas.Range("A" & LRow)
to this
ws.Range("A2:A" & wsLRow).Copy
mas.Range("A" & LRow).PasteSpecial xlPasteValues