Object doesnt support this property or method. Only happens on the .Paste section in this code. Please help, because I am perplexed. I have tried to simplify the code as much as posible to simply select the cell, copy the cell, select target, and paste. Something is missing here...
Sub AIM36DBOCompare()
Dim n As Integer
n = 2
Dim PasteCount As Integer
Dim Value1 As String
Dim Date1 As String
Dim c As Range
PasteCount = 41
Range("AD2:AD1000").Copy Destination:=Range("S41" & Lastrow)
Do While n <= 1000
If Cells(26, n) <> 0 Then
'--------------------------------------------
With Worksheets(1).Range("b2:b10000")
Set c = .Find(Cells(n, 26), LookIn:=xlValues)
If Not c Is Nothing Then
Do
Date1 = c.Offset(0, -1).Address
Value1 = c.Offset(0, 3).Address
If Abs(Cells(n, 25) - Range(Date1).Value) <= 10 Then
Range(Value1).Select
Selection.Copy
Cells(PasteCount, 17).Select
Selection.Paste
PasteCount = PasteCount + 1
Exit Do
End If
Set c = .Find(Cells(n, 26).Value, LookIn:=xlValues)
Loop While Not c Is Nothing
End If
End With
'--------------------------------------------
End If
If Cells(11, n) = 0 Then
Exit Do
End If
n = n + 1
Loop
End Sub
Or if you just want to copy the value, skip the whole select and paste:
Cells(PasteCount, 17).Value = Range(Value1).Value
You can't do Selection.Paste (As you have just observed). If you call Paste on the sheet, it will paste to your selection, try this instead
ActiveSheet.Paste
Related
I need help with the code below. What I am trying to do is, starting from the active cell (which could be any cell), select all cells to the right (=first column) + all the cells to the left (=last column) + all the cells above until the highlighted row + all the cell below until the highlighted row. Please see the attached data Sample Data
As an example, in the sample data, if the active cell is G6, then the code would select the entire range from A2 to J7. Similarly, if the active cell is F12, the code would select the entire range from A11 to J13.
Sub sel()
Dim LastCol As Long
With ActiveSheet
LastCol = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
Dim FirstCol As Long
With ActiveSheet
LastVrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(WorksheetFunction.Max(1, Selection.Row, LastVrow), _
WorksheetFunction.Max(1, Selection.Column, LastCol)), _
Cells(WorksheetFunction.Min(Selection.Worksheet.Rows.Count, _
Selection.Row), _
WorksheetFunction.Min(Selection.Worksheet.Columns.Count, _
Selection.Column, FirstCol))).Select
End With
End With
End With
End Sub
This will do what you want:
Sub foo2()
Dim rng As Range
Dim st As Long
Dim fin As Long
With Selection
If Cells(.Row - 1, 1) <> "" Then
st = Cells(.Row, 1).End(xlUp).Row
If st = 1 Then st = 2
Else
st = .Row
End If
If Cells(.Row + 1, 1) <> "" Then
fin = Cells(.Row, 1).End(xlDown).Row
Else
fin = .Row
End If
Set rng = Range("A" & st & ":J" & fin)
End With
rng.Select
End Sub
considering your template, maybe this could help:
sub sel()
dim selectRowS as integer
dim selectRowE as integer
with Selection
selectRowS = .row
selectRowE = .row
If Cells(.row + 1, 1) <> ""
selectRowE = .end(xlEnd).row
End If
If Cells(.row - 1, 1) <> ""
if .row - 1 = 1 then
selectRowS = 2
Else
selectRowS = .end(xlUp).row
End if
End If
Range(Cells(selectRowS,1),Cells(selectRowE,10)).select
End With
End Sub
P.S. Sorry my english
Maybe you could try this. Wherever the activecell cell is, first, move it to the first position and then select the entire block of data.
Sub Sel()
Selection.End(xlToLeft).Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
End Sub
I'm new to VBA, so I have to ask you for a help.
Below, I got VBA code which should sum data from different sheet [AB] based on value from first column of active sheet. The number of rows and columns is variable, so cell adresses need to be absolute.
Sub sumif_test
Range("A1").Select
Selection.End(xlDown).Select
abc = ActiveCell.Row
Selection.End(xlUp).Select
Selection.End(xlToRight).Select
ActiveCell.Offset(1, 1).Select
Dim mycrit As Variant
Dim myval As Variant
Dim CritRng As Range
Dim SumRng As Range
Set CritRng = Worksheets("AB").Range("A:A")
Set SumRng = Worksheets("AB").Range("N:N")
c = ActiveCell.Column
r = ActiveCell.Row
For r = 2 To abc - 2
mycrit = Cells(r, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
myval = Cells(r, c).Address(RowAbsolute:=False, ColumnAbsolute:=False)
myval = Application.WorksheetFunction.SumIf(CritRng, mycrit, SumRng)
Next r
End sub
With this code I don't get any result.
Try to avoid using select statements. Also learn to use the Application.ScreenUpdating property to speed up your code (This disables the screen refreshing between each write to the excel sheet and updates everything at the end making it much faster)
Sub sumif_test()
Dim ws As Worksheet
Dim NoCol As Integer, NoRow As Integer
Dim CritRng As Range, SumRng As Range
Application.ScreenUpdating = False
Set ws = Worksheets("AB")
With ws
NoRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
NoCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
Set CritRng = .Range("A:A")
Set SumRng = .Range("N:N")
End With
For r = 2 To NoRow
Cells(r, NoCol) = WorksheetFunction.SumIf(CritRng, Cells(r, 1), SumRng)
Next r
Application.ScreenUpdating = True
End Sub
I've rewritten your code to avoid using the select statement. Please take a look at it and see if you can figure out what each part does.
You need ranges and you need to set them. In your code, if you write debug.print after myval like this:
For r = 2 To abc - 2
mycrit = Cells(r, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
myval = Cells(r, c).Address(RowAbsolute:=False, ColumnAbsolute:=False)
myval = Application.WorksheetFunction.SumIf(CritRng, mycrit, SumRng)
debug.print myval
Next r
End sub
you would probably get some result in the immediate window. Ctrl+G.
In order to get some result try with:
For r = 2 To abc - 2
mycrit = Cells(r, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
myval = Cells(r, c).Address(RowAbsolute:=False, ColumnAbsolute:=False)
myval = Application.WorksheetFunction.SumIf(CritRng, mycrit, SumRng)
Cells(r,c) = myval
Next r
End sub
Finally - 2 things - try to avoid usage of select and format your code :)
Here you may find some examples of sumif with VBA.
I am trying to create VBA code that copies and pastes data from Column B into the row directly beneath in Column A. I do not have great experience with VBA and so I am struggling to create such a code.
I would like to create a code that loops for an entire set of data in Columns A and B as shown in the attached picture.
So for example, B3 would get pasted into A4. B5 would get pasted into A6. And all the way down until the list was completed.
Thank you for any help!
The below code works quite good for your criteria.
rowNum = 3
Do While Trim(Range("A" & rowNum).Value) <> ""
Range("A" & (rowNum + 1)).Value = Range("B" & rowNum).Value
rowNum = rowNum + 2
Loop
Here is a simple example that will do what you ask.
For i = 2 To 10
If Range("A" & i) > "" And Range("A" & i + 1) = "" Then
Range("B" & i).Cut
Range("A" & i + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Else
End If
Next
Depending on what your data looks like, you will probably want to setup something more dynamic for the value of 'i'.
Use LastRowIndex from https://stackoverflow.com/a/71296/42346 to find the final row then iterate over the rows in column 2 placing the value in column 1 one row below the current row.
Sub iterate()
Dim r As Long
Dim c As Long
Dim endrow As Long
c = 2
endrow = LastRowIndex(ActiveSheet, c)
For r = 2 To endrow Step 1
If ActiveSheet.Cells(r, c).Value <> "" Then
ActiveSheet.Cells(r + 1, c - 1).Value = ActiveSheet.Cells(r, c).Value
End If
Next r
End Sub
Function LastRowIndex(ByVal w As Worksheet, ByVal col As Variant) As Long
Dim r As Range
Set r = Application.Intersect(w.UsedRange, w.Columns(col))
If Not r Is Nothing Then
Set r = r.Cells(r.Cells.Count)
If IsEmpty(r.Value) Then
LastRowIndex = r.End(xlUp).Row
Else
LastRowIndex = r.Row
End If
End If
End Function
I have two columns of numbers, together they will be unique (composite key). I would like to create an unique ID number (third column) similar to how MS Access would use a primary key. I would like to do this in VBA but I am stuck on how to do it.
My VBA in excel isn't very good so hopefully you can see what I've started to attempt. it may be completely wrong... I don't know?
I don't know how to make the next concatenation and I am unsure about how to go down to the next row correctly.
Sub test2()
Dim var As Integer
Dim concat As String
concat = Range("E2").Value & Range("F2").Value
var = 1
'make d2 activecell
Range("D2").Select
Do Until concat = ""
'if the concat is the same as the row before we give it the same number
If concat = concat Then
var = var
Else
var = var + 1
End If
ActiveCell.Value = var
ActiveCell.Offset(0, 1).Select
'make the new concatination of the next row?
Loop
End Sub
any help is appreciated, thanks.
Give the code below a try, I've added a loop which executes for each cell in the E Column. It checks if the concat value is the same as the concat value in the row above and then writes the id to the D cell.
Sub Test2()
Dim Part1 As Range
Dim strConcat As String
Dim i As Long
i = 1
With ThisWorkbook.Worksheets("NAME OF YOUR SHEET")
For Each Part1 In .Range(.Cells(2, 5), .Cells(2, 5).End(xlDown))
strConcat = Part1 & Part1.Offset(0, 1)
If strConcat = Part1.Offset(-1, 0) & Part1.Offset(-1, 1) Then
Part1.Offset(0, -1).Value = i
Else
i = i + 1
Part1.Offset(0, -1).Value = i
End If
Next Part1
End With
End Sub
Something like this should work, this will return a Unique GUID (Globally Unique Identifier):
Option Explicit
Sub Test()
Range("F2").Select
Do Until IsEmpty(ActiveCell)
If (ActiveCell.Value <> "") Then
ActiveCell.Offset(0, 1).Value = CreateGUID
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Public Function CreateGUID() As String
CreateGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function
If you walk down column D and examine the concatenated values from column E and F with the previous row, you should be able to accomplish your 'primary key'.
Sub priKey()
Dim dcell As Range
With Worksheets("Sheet12")
For Each dcell In .Range(.Cells(2, 4), .Cells(Rows.Count, 5).End(xlUp).Offset(0, -1))
If LCase(Join(Array(dcell.Offset(0, 1).Value2, dcell.Offset(0, 2).Value2), ChrW(8203))) = _
LCase(Join(Array(dcell.Offset(-1, 1).Value2, dcell.Offset(-1, 2).Value2), ChrW(8203))) Then
dcell = dcell.Offset(-1, 0)
Else
dcell = Application.Max(.Range(.Cells(1, 4), dcell.Offset(-1, 0))) + 1
End If
Next dcell
End With
End Sub
You could use collections as well.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range, LstRw As Long
Dim Cell As Range
Dim vNum As Variant, c As Range, y
LstRw = Cells(Rows.Count, "E").End(xlUp).Row
Set Rng = Range("E2:E" & LstRw)
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value & Cell.Offset(, 1), CStr(Cell.Value & Cell.Offset(, 1))
Next Cell
On Error GoTo 0
y = 1
For Each vNum In cUnique
For Each c In Rng.Cells
If c & c.Offset(, 1) = vNum Then
c.Offset(, -1) = y
End If
Next c
y = y + 1
Next vNum
End Sub
i'm new to vba and i was trying to make a program to do add multiple items to a key.
Eg:
Table
Name Date Time
XYZ 20 4
ABC 21 5
XYZ 22 6
and then if the names are repeated, then column values to the previous one...like:
Name Date Time Date Time
XYZ 20 4 22 6
ABC 21 5
i've done sorting and adding the sum of duplicate values for a single item value but i'm finding it hard to do this for multivalued item. So plz do help out!!
Thank you!!
Sub t()
Application.DisplayAlerts = False
Dim Tempsheet As Worksheet
Dim c As Range
Set Tempsheet = ThisWorkbook.Sheets.Add
With ThisWorkbook.Sheets("sheet1")
rng = .UsedRange.Address
.UsedRange.Sort key1:=.Range("b1"), order1:=xlAscending, key2:=.Range("c1"), order2:=xlAscending, Header:=xlYes
.UsedRange.Columns(1).Copy
Tempsheet.Range("a1").PasteSpecial (xlPasteValues)
Tempsheet.Columns(1).RemoveDuplicates Columns:=1, Header:=xlYes
For Each cell In Tempsheet.Range("a1:a" & Tempsheet.Range("a" & Rows.Count).End(xlUp).Row).Cells
i = i + 1
If i <> 1 Then
With .Range(rng)
Set c = .Find(what:=cell.Value, after:=.Range("a1"), LookIn:=xlValues, lookat:=xlWhole)
firstAddress = c.Address
If Not c Is Nothing Then
Do
j = j + 1
If j <> 1 Then
k = k + 1
.Range(c.Offset(0, 1), c.Offset(0, 2)).Copy
.Range(firstAddress).Offset(0, (k * 2) + 1).PasteSpecial (xlPasteValues)
.Range(firstAddress).Offset(-1, (k * 2) + 1) = "Date"
.Range(firstAddress).Offset(-1, (k * 2) + 2) = "Time"
c.EntireRow.ClearContents
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End If
j = 0
Next cell
.UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Tempsheet.Delete
End Sub
You are writing an elaborate program for something that is a basic part of the Excel functionality. It is called Pivot tables.
https://en.wikipedia.org/wiki/Pivot_table
http://www.excel-easy.com/data-analysis/pivot-tables.html