I have a copy-if routine where I have had trouble finding how to paste values only. Can someone please help?
My routine is as follows:
Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = Workbooks("Bok2.xlsx").Sheets("Ark1")
Dim ws2 As Worksheet: Set ws2 = Workbooks("Bok2.xlsx").Sheets("Ark2")
Dim ws3 As Worksheet: Set ws3 = ThisWorkbook.Sheets("Ark1")
For i = 2 To ws1.Range("A100").End(xlUp).Row
If ws1.Cells(i, 1) = "Videreføres" Then ws2.Range("B1:B100")(i).Copy ws3.Range("A1:A100")(ws3.Cells(ws3.Range("A1:A100").Count, 1).End(xlUp).Row + 1)
If ws1.Cells(i, 1) = "Videreføres" Then ws2.Range("C1:C100")(i).Copy ws3.Range("B1:B100")(ws3.Cells(ws3.Range("B1:B100").Count, 1).End(xlUp).Row + 0)
If ws1.Cells(i, 1) = "Videreføres" Then ws2.Range("E1:E100")(i).Copy ws3.Range("C1:C100")(ws3.Cells(ws3.Range("C1:C100").Count, 1).End(xlUp).Row + 0)
Next i
End Sub
You're just pasting what you've copied where as in fact you need to use the PasteSpecial function. Try looking at this:
Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Workbooks("Bok2.xlsx").Sheets("Ark1")
Set ws2 = Workbooks("Bok2.xlsx").Sheets("Ark2")
Set ws3 = ThisWorkbook.Sheets("Ark1")
For i = 2 To ws1.Range("A100").End(xlUp).Row
If ws1.Cells(i, 1) = "Videreføres" Then
With ws2
.Range("B1:B100")(i).Copy
ws3.Range("A1:A100")(ws3.Cells(ws3.Range("A1:A100").Count, 1).End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues
.Range("C1:C100")(i).Copy
ws3.Range("B1:B100")(ws3.Cells(ws3.Range("B1:B100").Count, 1).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues
.Range("E1:E100")(i).Copy
ws3.Range("C1:C100")(ws3.Cells(ws3.Range("C1:C100").Count, 1).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues
End With
End If
Next i
End Sub
Related
I have a table with certain rows with "striked-out" font. The objective is to cut these rows and paste them into another sheet.
So far, I have the following code, and is not working (EDIT: a new sheet gets created but nothing is cut nor pasted):
Sub test()
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets.Add After:=ActiveSheet
For i = 2 To lrow
If Cells(i, 1).Font.Strikethrough = True Then
Cells(i, 1).EntireRow.Cut
Sheets(ActiveSheet.Index + 1).Paste
End If
Next i
End Sub
How would I fix this?
More like this:
Sub test()
Dim i As Long, lrow As Long, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Long
Set wsSrc = ActiveSheet 'or something more specific
lrow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
'get a reference to the sheet when adding it
Set wsDest = wsSrc.Parent.Sheets.Add(After:=ActiveSheet)
destRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
For i = 2 To lrow
If wsSrc.Cells(i, 1).Font.Strikethrough = True Then
wsSrc.Rows(i).Cut wsDest.Cells(destRow, 1)
destRow = destRow + 1 'next paste row
End If
Next i
End Sub
I know similar questions have been asked in the past, but looking through those posts, I haven't been able to find a solution to the following issue.
I have 2 subs that use Bloomberg API formulas. In the second (Setup_2) the variable LastRow1 is dependent on Setup_1 having populated to work properly.
Using checkStatus_1 and checkStatus_2 I can run each of the 2 setup subs independently, but when I try to create a separate sub calling them, it doesn't work, as the data that LastRow1 depends on isn't there.
Here is the relevant code:
Sub Setup_1()
Dim ws1 As Worksheet
Set ws1 = Worksheets("Returns")
ws1.Cells(2, 1).Formula = "=BDS(Control!B4,""INDX_MWEIGHT_HIST"",""END_DATE_OVERRIDE"",TEXT($A$1,""YYYYMMDD""))"
ws1.Cells(1, 4).Formula = "=BDH(A2&"" Equity"",""DAY_TO_DAY_TOT_RETURN_GROSS_DVDS"",$B$1,$A$1,""dir=h"")"
ws1.Cells(3, 4).Formula = "=BDH(A3&"" Equity"",""DAY_TO_DAY_TOT_RETURN_GROSS_DVDS"",$B$1,$A$1,""dir=h"",""dts=h"")"
checkStatus_1
End Sub
Sub Setup_2()
Dim ws1 As Worksheet
Set ws1 = Worksheets("Returns")
Dim LastRow1 As Long
LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws1.Cells(3, 4).Formula = "=BDH(A3&"" Equity"",""DAY_TO_DAY_TOT_RETURN_GROSS_DVDS"",$B$1,$A$1,""dir=h"",""dts=h"")"
ws1.Cells(3, 4).AutoFill Destination:=ws1.Range(ws1.Cells(3, 4), ws1.Cells(LastRow1, 4))
checkStatus_2
End Sub
Sub Setup_3()
Dim ws1 As Worksheet
Set ws1 = Worksheets("Returns")
Dim LastRow1 As Long
Dim LastCol1 As Long
Dim LCol As String
LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
LastCol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
LCol = Split(Cells(, LastCol1).Address, "$")(1)
ws1.Cells(2, 3).Formula = "=(STDEV.S(D2:" & LCol & "2)*SQRT(252))/100"
ws1.Cells(2, 3).AutoFill Destination:=ws1.Range(ws1.Cells(2, 3), ws1.Cells(LastRow1, 3))
End Sub
Sub checkStatus_1()
Dim ws1 As Worksheet
Dim rng As Range
Dim c As Range
Set ws1 = Worksheets("Returns")
Set rng = Application.Union(ws1.Cells(2, 1), ws1.Cells(1, 4), ws1.Cells(3, 4))
For Each c In rng
If "#N/A Requesting Data..." = c Or "#N/A Invalid Securiity" = c Then
Application.OnTime (Now + TimeValue("00:00:02")), "checkStatus_1"
Exit Sub
End If
Next c
End Sub
Sub checkStatus_2()
Dim ws1 As Worksheet
Dim rng As Range
Dim c As Range
Dim LastRow1 As Long
Set ws1 = Worksheets("Returns")
LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws1.Range(ws1.Cells(3, 4), ws1.Cells(LastRow1, 4))
For Each c In rng
If "#N/A Requesting Data..." = c Then
Application.OnTime (Now + TimeValue("00:00:02")), "checkStatus_2"
Exit Sub
End If
Next c
End Sub
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.
If the sheet name is "Central " (with a space at the end of the word), zone = "Central" returns an error and the sheet cannot be activated.
How do i correct this?
dim wb1, wb2, wb3 as workbook
set wb1 = activeworkbook 'the macro file
dim ws1, ws2 as worksheet
set ws1 = Sheets("Central Zone")
set ws2 = Sheets("Eastern Zone")
For x = 1 To 2
If x = 1 Then
Set ws = ws1
zone = "Central"
End If
If x = 2 Then
Set ws = ws2
zone = "East"
End If
wb2.Sheets(zone).Activate 'wb2 is source file 1. I have wb3, wb4, etc
Selection.EntireColumn.Hidden = False
Range("A1").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.EntireRow.Select
Selection.Copy
wb1.Activate
ws.Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Next x
It's allways recommended to stay away from Activate, Selection, Select and all other "relatives". Instead use referenced objects, like Sheets, and `Ranges.
The code below is a little "quick and dirty" but it should give you the result you want
Code
Option Explicit
Sub CopyCentralSheets()
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, Sht As Worksheet, ws As Worksheet
Dim LastRow As Long, LastColumn As Long, PasteRow As Long, x As Long
Set wb1 = ThisWorkbook ' this macro file
'Set wb2 = Workbooks("temp.xlsx") 'for my debug tests only
Set ws1 = wb1.Sheets("Central Zone")
Set ws2 = wb1.Sheets("Eastern Zone")
For x = 1 To 2
If x = 1 Then
For Each Sht In wb2.Worksheets
If Sht.Name Like "Central*" Then
Set ws = Sht
End If
Next Sht
Else
If x = 2 Then
For Each Sht In wb2.Worksheets
If Sht.Name = "East" Then
Set ws = Sht
End If
Next Sht
End If
End If
With ws
LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
LastColumn = .UsedRange.Columns(.UsedRange.Columns.Count).Column
.Range(.Cells(1, 1), .Cells(LastRow, LastColumn)).Copy
End With
If x = 1 Then
With ws1
PasteRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & PasteRow + 1).PasteSpecial xlValues
End With
Else
If x = 2 Then
With ws2
PasteRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & PasteRow + 1).PasteSpecial xlValues
End With
End If
End If
Next x
End Sub
What I want to achieve is to copy data from WS1 to WS3 based on certain criteria.
I have 2 worksheets:
WS1 = RAW DATA
WS2 = ATLAS DATA
In columns A of both there are unique identifiers. What I want to do is to create WS3=Reconciliation. Then look up values in WS2 against WS1. Where a match is found I want to copy row(s) from WS1 to WS3 that all
I have reverse engineered some code and came up with one below
Sub CopyAndPaste()
Dim x As String, CpyRng As Range
Dim mFIND As Range, mFIRST As Range
With Sheets("RAW DATA")
Range("A:A").Select
On Error Resume Next
End With
With Sheets("ATLAS DATA")
Set mFIND = .Range("A:A").Find(x, LookIn:=xlValues, LookAt:=xlWhole)
If Not mFIND Is Nothing Then
Set CpyRng = mFIND
Set mFIRST = mFIND
Do
Set CpyRng = Union(CpyRng, mFIND)
Set mFIND = .Range("A:A").FindNext(mFIND)
Loop Until mFIND.Address = mFIRST.Address
CpyRng.EntireRow.Copy Sheets("Rec").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End With
End Sub
Based on your description of your problem; try this
Option Explicit
Sub CopyAndPaste()
Application.ScreenUpdating = False
Dim i As Long, j As Long, lastRow1 As Long, lastRow2 As Long, cnt As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = ActiveWorkbook.Sheets("RAW DATA")
Set ws2 = ActiveWorkbook.Sheets("ATLAS DATA")
Set ws3 = ActiveWorkbook.Sheets("Reconciliation")
lastRow1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
lastRow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
cnt = 1
For i = 1 To lastRow1
For j = 1 To lastRow2
If StrComp(CStr(ws2.Range("A" & j).Value), _
CStr(ws1.Range("A" & i).Value), _
vbTextCompare) = 0 Then
ws1.Activate
ws1.Rows(i).Select
Selection.Copy
ws3.Activate
ws3.Range("A" & cnt).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Application.CutCopyMode = False
cnt = cnt + 1
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub