I am using code below which I am trying to change so as not to use .select
Selection.Select ' from active worksheet
Selection.Copy
Sheets("Purch Req").Select
Range("A1").Select
ActiveSheet.Paste
I have tried using this but there is no output to the other worksheet.
Dim src2Range As Range, dest2Range As Range
Set src2Range = Selection 'source from selected range
Set dest2Range = Sheets("Purch Req").Range("A1").Resize(src2Range.Rows.Count, src2Range.Columns.Count) ' destination range _
'in Purch req worksheet
Here is good examples on How to avoid using Select in Excel VBA Link stackoverflow
Here is simples of
copy/paste - values = values - PasteSpecial method
Option Explicit
'// values between cell's
Sub PasteValues()
Dim Rng1 As Range
Dim Rng2 As Range
Set Rng1 = Range("A1")
Set Rng2 = Range("A2")
Rng2.Value = Rng1.Value
'or
[A2].Value = [A1].Value
'or
Range("A2").Value = Range("A1").Value
'or
Set Rng1 = Range("A1:A3")
Set Rng2 = Range("A1:A3")
Rng2("B1:B3").Value = Rng1("A1:A3").Value
'or
[B1:B3].Value = [A1:A3].Value
'// values between WorkSheets
Dim xlWs1 As Worksheet
Dim xlWs2 As Worksheet
Set xlWs1 = Worksheets("Sheet1")
Set Rng1 = xlWs1.Range("A1")
Set xlWs2 = Worksheets("Sheet2")
Set Rng2 = xlWs2.Range("A1")
Rng2.Value = Rng1.Value
'or
Set Rng1 = [=Sheet1!A1]
Set Rng2 = [=Sheet2!A1]
Rng2.Value = Rng1.Value
'or
[=Sheet2!A1].Value = [=Sheet1!A1].Value
'or
Worksheets("Sheet2").Range("A2").Value = Worksheets("Sheet1").Range("A1").Value
'// values between workbooks
Dim xlBk1 As Workbook
Dim xlBk2 As Workbook
Set xlBk1 = Workbooks("Book1.xlsm")
Set Rng1 = xlBk1.Worksheets("Sheet1").Range("A1")
Set xlBk2 = Workbooks("Book2.xlsm")
Set Rng2 = xlBk2.Worksheets("Sheet1").Range("A1")
Rng2.Value = Rng1.Value
'or
Set Rng1 = Evaluate("[Book1.xlsm]Sheet1!A1")
Set Rng2 = Evaluate("[Book2.xlsm]Sheet2!A1")
Rng2.Value = Rng1.Value
'or
Evaluate("[Book2.xlsm]Sheet2!A1").Value = Evaluate("[Book1.xlsm]Sheet1!A1")
'or
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").Value = _
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Value
End Sub
Simple copy/paste
Sub CopyRange()
Dim Rng1 As Range
Dim Rng2 As Range
Set Rng1 = Range("A1")
Set Rng2 = Range("A2")
Rng1.Copy Rng2
[A1].Copy [A2]
Range("A2").Copy Range("A1")
'// Range.Copy to other worksheets
Dim xlWs1 As Worksheet
Dim xlWs2 As Worksheet
Set xlWs1 = Worksheets("Sheet1")
Set Rng1 = xlWs1.Range("A1")
Set xlWs2 = Worksheets("Sheet2")
Set Rng2 = xlWs2.Range("A1")
Rng1.Copy Rng2
Set Rng1 = [=Sheet1!A1]
Set Rng2 = [=Sheet2!A1]
Rng1.Copy Rng2
[=Sheet1!A1].Copy [=Sheet2!A1]
Worksheets("Sheet1").Range("A1").Copy Worksheets("Sheet2").Range("A1")
''// Range.Copy to other workbooks
Dim xlBk1 As Workbook
Dim xlBk2 As Workbook
Set xlBk1 = Workbooks("Book1.xlsm")
Set Rng1 = xlBk1.Worksheets("Sheet1").Range("A1")
Set xlBk2 = Workbooks("Book2.xlsm")
Set Rng2 = xlBk2.Worksheets("Sheet2").Range("A2")
Rng1.Copy Rng2
Evaluate("[Book1.xlsm]Sheet1!A1").Copy Evaluate("[Book2.xlsm]Sheet2!A2")
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy _
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1")
End Sub
PasteSpecial method
Sub PasteSpecial()
'Copy and PasteSpecial a Range
Range("A1").Copy
Range("A3").PasteSpecial Paste:=xlPasteFormats
'Copy and PasteSpecial a between worksheets
Worksheets("Sheet1").Range("A2").Copy
Worksheets("Sheet2").Range("A2").PasteSpecial Paste:=xlPasteFormulas
'Copy and PasteSpecial between workbooks
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End Sub
There is many ways to do that, but here goes two.
1)
Sub pasteExcel()
Dim src2Range As Range
Dim dest2Range As Range
Dim r 'to store the last row
Dim c 'to store the las column
Set src2Range = Selection 'source from selected range
r = Range("A1").End(xlDown).Row 'Get the last row from A1 to down
c = Range("A1").End(xlToRight).Column 'Get the last Column from A1 to right
Set dest2Range = Range(Cells(1, 1), Cells(r, c))
dest2Range.PasteSpecial xlPasteAll
Application.CutCopyMode = False 'Always use the sentence.
End Sub
2)
Sub pasteExcel2()
Dim sht1 As Worksheet
Dim sht2 As Worksheet 'not used!
Dim src2Range As Range
Dim dest2Range As Range
Dim r 'to store the last row
Dim c 'to store the las column
Set sht1 = Sheets("Sheet1")
Set sht2 = Sheets("Sheet2")
sht1.Activate 'Just in case... but not necesary
r = Range("A1").End(xlDown).Row 'Get the last row from A1 to down
c = Range("A1").End(xlToRight).Column 'Get the last Column from A1 to right
Set src2Range = Range(Cells(1, 1), Cells(r, c)) 'source from selected range
Set dest2Range = Range(Cells(1, 1), Cells(r, c))
sht2.Range(dest2Range.Address).Value = src2Range.Value 'the same range in the other sheet.
End Sub
Tell me if you need some improvement.
Related
i have some data in range A1 to EA6000 in sheet "RB". In that range in row 30 some cells with specify date i marked on VBgreen color. Now i need VBA to find columns which contain cells with VBgreen, copy those columns and paste one by one to sheet "Plan" starting from column AA, then Ab etc. (AA+1) .
I tried with that code but faied....
Sub CopyColumnsWithGreenCells()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim sourceRange As Range
Dim targetRange As Range
Dim i As Integer
Dim j As Integer
Dim firstEmptyColumn As Integer
Set sourceSheet = ThisWorkbook.Sheets("RB")
Set targetSheet = ThisWorkbook.Sheets("plan")
Set sourceRange = sourceSheet.Range("AA:EA")
firstEmptyColumn = targetSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
For i = 1 To sourceRange.Columns.Count
For j = 1 To sourceRange.Rows.Count
If sourceRange.Cells(j, i).Interior.Color = vbGreen Then
Set targetRange = targetSheet.Range(targetSheet.Cells(1, firstEmptyColumn), targetSheet.Cells(sourceRange.Rows.Count, firstEmptyColumn))
sourceRange.Columns(i).Copy
targetRange.PasteSpecial xlPasteValues
firstEmptyColumn = firstEmptyColumn + 1
Exit For
End If
Next j
Next i
End Sub
You could try something like this:
Sub CopyColumnsWithGreenCells()
Dim sourceSheet As Worksheet, wb As Workbook
Dim sourceRange As Range, targetRange As Range
Dim col As Range, f As Range
Set wb = ThisWorkbook
Set targetRange = wb.Sheets("plan").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
Application.FindFormat.Clear 'reset FindFormat
Application.FindFormat.Interior.Color = vbGreen 'background color
For Each col In wb.Sheets("RB").Range("AA:EA").Columns
Set f = col.Find(what:="*", LookIn:=xlValues, SearchFormat:=True)
If Not f Is Nothing Then 'got a match?
targetRange.Resize(col.Rows.Count, col.Columns.Count).Value = col.Value
Set targetRange = targetRange.Offset(0, 1) 'next destination
End If
Next col
Application.FindFormat.Clear
End Sub
I have been trying to make a function where it matches 2 separate strings with two column then copy corresponding columns data and paste into separate sheet.
I am stuck on that thing how to make 2 matches like For Each cell In myDataRng & myDataRng2.
your help will be appreciated
Sub Tester()
Dim myDataRng, myDataRng2 As Range
Dim cell As Range, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Range
Dim FindValue As String
Dim FindValue2 As String
Set wsSrc = Worksheets("Sheet1") 'source sheet
Set wsDest = Worksheets("Sheet2") 'destination sheet
FindValue = wsDest.Range("A2").Value
FindValue2 = wsDest.Range("B2").Value
Set myDataRng = wsSrc.Range("F2:F" & wsSrc.Cells(Rows.Count, "F").End(xlUp).Row)
Set myDataRng2 = wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row)
Set destRow = wsDest.Rows(2) 'first destination row
For Each cell In myDataRng
If InStr(1, cell.Value, FindValue) > 0 Then
With cell.EntireRow 'the whole matching row
destRow.Cells(5).Value = .Cells(2).Value
destRow.Cells(6).Value = .Cells(3).Value
destRow.Cells(7).Value = .Cells(4).Value
destRow.Cells(8).Value = .Cells(5).Value
End With
Set destRow = destRow.Offset(1, 0) 'next destination row
End If
Next cell
End Sub
Other Condition
Sub find()
Dim foundRng As Range
Dim mValue As String
Set shData = Worksheets("Sheet1")
Set shSummary = Worksheets("Sheet2")
mValue = shSummary.Range("C2")
Set foundRng = shData.Range("G1:Z1").find(mValue)
'If matches then copy macthed Column and paste into Sheet2 Col"I" (as above code psting the data into Sheet2)
End Sub
Several options:
If Instr(1, cell.Offset(,-5).Value, FindValue2) > 0 Then
If InStr(1, wsSrc.Range("A" & cell.Row), FindValue2) > 0 Then
and others.
I like using rows for loops like this because it makes it very easy to read the code and understand what is happening. By breaking the search range into a series of rows, everything becomes simple to write and read.
Sub Tester()
Dim myDataRng, myDataRng2 As Range
Dim rRow As Range, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Range
Dim FindValue As String
Dim FindValue2 As String
Set wsSrc = Worksheets("Sheet1") 'source sheet
Set wsDest = Worksheets("Sheet2") 'destination sheet
FindValue = wsDest.Range("A2").Value
FindValue2 = wsDest.Range("B2").Value
Set myDataRng = wsSrc.Range("F2:F" & wsSrc.Cells(Rows.Count, "F").End(xlUp).Row)
'Set myDataRng2 = wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row)
Set destRow = wsDest.Rows(2) 'first destination row
For Each rRow In myDataRng.Rows.EntireRow
If InStr(1, rRow.Columns("F").Value, FindValue) > 0 _
And InStr(1, rRow.Columns("A").Value, FindValue2) > 0 Then
With rRow.EntireRow 'the whole matching row
destRow.Cells(5).Value = .Cells(2).Value
destRow.Cells(6).Value = .Cells(3).Value
destRow.Cells(7).Value = .Cells(4).Value
destRow.Cells(8).Value = .Cells(5).Value
End With
Set destRow = destRow.Offset(1, 0) 'next destination row
End If
Next rRow
End Sub
Set wsSrc = Worksheets("Sheet1") 'source sheet
Set wsDest = Worksheets("Sheet2") 'destination sheet
FindValue = wsDest.Range("A2").Value
FindValue2 = wsDest.Range("B2").Value
Set myDataRng = wsSrc.Range("F2:F" & wsSrc.Cells(Rows.Count, "F").End(xlUp).Row)
'Set myDataRng2 = wsSrc.Range("A2:A" & wsSrc.Cells(Rows.Count, "A").End(xlUp).Row)
Set destRow = wsDest.Rows(2) 'first destination row
For Each rRow In myDataRng.Rows
If InStr(1, rRow.Columns("F").Value, FindValue) > 0 _
And InStr(1, rRow.Columns("A").Value, FindValue2) > 0 Then
With rRow.EntireRow 'the whole matching row
destRow.Cells(5).Value = .Cells(2).Value
destRow.Cells(6).Value = .Cells(3).Value
destRow.Cells(7).Value = .Cells(4).Value
destRow.Cells(8).Value = .Cells(5).Value
End With
Set destRow = destRow.Offset(1, 0) 'next destination row
End If
Next rRow
End Sub
I am trying to save data from sheet("Billing") to another sheets("Bill_Register") with formats and values not formulas. Pasteformats and pastevalues are working separately not together. Please suggest me a better VBA. Thanks in advance.
Sub Save_invoice()
Dim i As Integer
Dim last As Long
Dim rng As Range, rng2 As Range
last = Sheets("Bill_Register").Range("A100000").End(xlUp).Row
Set rng = Sheets("Billing").Range("A1:J42")
Set rng2 = Sheets("Bill_Register").Range("A" & last + 2)
rng.Copy
rng2.PasteSpecial Paste:=xlPasteFormats
rng.Copy
rng2.PasteSpecial Paste:=xlPasteValues
End Sub
If you have merged cells and use xlPasteValues then an error will occur.
use variant array.
Sub Save_invoice()
Dim i As Integer
Dim last As Long
Dim rng As Range, rng2 As Range
Dim vDB
last = Sheets("Bill_Register").Range("A100000").End(xlUp).Row
Set rng = Sheets("Billing").Range("A1:J42")
vDB = rng '<~~ set array
Set rng2 = Sheets("Bill_Register").Range("A" & last + 2)
rng.Copy
rng2.PasteSpecial Paste:=xlPasteFormats
rng2.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB '<~~ get value
End Sub
If rng and rng2 have the exactly same size (rows and columns) then you can use this to get the values:
rng2.Cells.Value = rng.Cells.Value
Some MCVE:
Public Sub TestMe()
Dim rng As Range
Dim rng2 As Range
Set rng = Range("A1:B2")
Set rng2 = Range("D2:E3")
rng2.Cells.Value = rng.Cells.Value
End Sub
If you are interested in the number formatting etc. but not necessarily the fill colour etc. then you could use:
Rng.Copy
rng2.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
There is no reason to copy twice, once it is in the clipboard it is there till replaced.
Paste the values first then the format:
Sub Save_invoice()
Dim i As Integer
Dim last As Long
Dim rng As Range, rng2 As Range
last = Sheets("Bill_Register").Range("A100000").End(xlUp).Row
Set rng = Sheets("Billing").Range("A1:J42")
Set rng2 = Sheets("Bill_Register").Range("A" & last + 2)
rng.Copy
rng2.PasteSpecial Paste:=xlPasteValues
rng2.PasteSpecial Paste:=xlPasteFormats
End Sub
How do I transpose the output in the code below?
Dim lastRow As Range, rng1 As Range
Set rng1 = Worksheets(1).Range("I80:I83")
Set lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(ThisWorkbook.Worksheets("Sheet1").Rows.Count, "B").End(xlUp)
lastRow.Offset(1, 0).Resize(rng1.Rows.Count, rng1.Columns.Count) = rng1.Value
It should work. Consider the following example: (can't fit to comment)
With Sheet1 '/* or what ever your sheet object is */
.Range("A1") = 1
.Range("A2") = 2
.Range("A3") = 3
.Range("C1:E1") = Application.Transpose(.Range("A1:A3"))
End With
Applying to your code:
Dim lastRow As Range, rng1 As Range
With Thisworkbook.Sheets(1)
Set rng1 = .Range("I80:I83")
Set lastrow = .Range("B" & .Rows.Count).End(xlUp)
lastrow.Offset(1, 0).Resize(rng1.Columns.Count, rng1.Rows.Count) = rng1.Value
End With
First get the range of non-empty cells from Source workbook. Then select similar range of cells in Destination Workbook. How can this be achieved?
Full Code::
~~~~~~~~~~~
Public Sub ConvertTo_K()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Workbooks("Source.xls").Worksheets("Source").Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp).Resize(, 1))
Set rng2 = Workbooks("Destination.xls").Worksheets("Destination").Range(rng1.Address)
rng2.Value = Round(rng1.Value / 1000, 2)
'At this point, an error message of Type Mismatch pops up (Due to different ranges of rng1 and rng2). Do i have to use a loop? How to do that?
End Sub
Round(rng1.Value / 1000, 2) will not work because rng1 is a collection of ranges and can be accessed by rng1.Cells(1).value
rng1.Value is not valid.
You may loop thru each cell of rng2 and apply the round formula.
Public Sub ConvertTo_K()
Dim rng1 As Range
Dim rng2 As Range
Dim RoundRange As Range
Dim rngVal As Double
Dim SourceWkb As Workbook
Set SourceWkb = Workbooks("Source.xls")
Dim SourceSht As Worksheet
Set SourceSht = SourceWkb.Worksheets("Source")
With SourceSht
Set rng1 = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp).Resize(, 1))
End With
Dim DestinWkb As Workbook
Set DestinWkb = ThisWorkbook 'Workbooks("Destination.xls")
Dim DestinSht As Worksheet
Set DestinSht = DestinWkb.Worksheets("Destination")
With DestinSht
Set rng2 = .Range(rng1.Address)
End With
'rng2.Value = Round(rng1.Value / 1000, 2) This wont work
rng1.Copy rng2
For Each cell In rng2
cell.Value = Round(cell / 1000, 2)
Next
End Sub
If your rng1 works fine you could do it this way:
set rng2 = Workbooks("Destination.xls").Worksheets("Destination").Range(rng1.address)