How to work with the range method with only one specific cell? - excel

I would like the cells I have selected in the spreadsheet to receive the +1 increment. The code below works fine when I have a range, but when I have only one cells selected the code adds +1 to every cell in the spreadsheet.
Sub Macro_MAIS_1()
'
' Macro_MAIS_1 Macro
'
'
Dim AlocationWorksheet As Worksheet
Dim ActSheet As Worksheet
Dim SelRange As Range
Dim iCells As Integer
On Error GoTo Fim
Set AlocationWorksheet = Worksheets("ALOCAÇÃO")
AlocationWorksheet.Unprotect
Set ActSheet = ActiveSheet
Set SelRange = Selection.SpecialCells(xlCellTypeVisible)
iCells = SelRange.Cells.Count
Range("O7").Select
Selection.Copy
SelRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
:=False, Transpose:=False
Exit Sub
Fim:
MsgBox Selection.Address
Range("O7").Select
Selection.Copy
SelRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
:=False, Transpose:=False
End Sub

I would avoid using a selection, but this should work. If you have text you'll run into trouble and need to write out some checks. You also should not be counting all cells, as you might have an overflow of values. Check rows and columns, but not both.
Sub addPlusOne()
Dim aRange As Range, i As Long, j As Long
Set aRange = Selection
If aRange.Rows.Count > 1 Or aRange.Columns.Count > 1 Then
Dim zRng()
zRng = aRange.Value
For i = LBound(zRng) To UBound(zRng)
For j = LBound(zRng, 2) To UBound(zRng, 2)
zRng(i, j) = zRng(i, j) + 1
Next j
Next i
aRange.Value = zRng
Else
aRange.Value = aRange.Value + 1
End If
End Sub
EDIT: OP commented that they want to use visible selection. While this isn't best practice, this will work.
Sub plusOneOnSelection()
Dim aCell As Range
For Each aCell In Selection.SpecialCells(xlCellTypeVisible).Cells
If IsNumeric(aCell) Then aCell.Value = aCell.Value + 1
Next aCell
End Sub

Related

How can I select the exact number of items after applying the filter?

I need to select a group of items after applying the filter and it works until a certain number of items.
I use 'Areas' to select the set of items because sometimes it needs to select the first one, two, three... until ten items. The variable which determines how long the selection will be is called rangeA, rangeB and rangeC for SELECTION A, SELECTION B and SELECTION C, respectively. Also, the number of columns for each selection is always the same. After the selection is done it's copied and pasted for each selection. It works this way:
the filter is applied
the selection (A, B and C one per time) is copied
the selection is pasted on the "Worksheet 2"
for selection A, B and C.
One observation is that I will always have items to select because "DATA" is too big, it has over 13 thousand items.
Sub SELECT()
Dim area As Range
Dim CellCount As Integer
Dim firstCell As Range 'firstCell and lastCell determines how big the selection will be.
Dim lastCell As Range
Dim rangeA, rangeB, rangeC As Variant
rangeA = Range("v20").Value 'this is the cell where the number of rows I want (one to ten)
rangeB = Range("v21").Value
rangeC = Range("v22").Value
'############# SELECTION A #################'
'##########################################
Application.Goto ActiveWorkbook.Sheets("DATA").Cells(11, 3)
ActiveSheet.Range("$A$11:$P$65").AutoFilter Field:=10, Criteria1:= _
"FILTER X"
ActiveSheet.Range("$A$11:$P$74").AutoFilter Field:=7, Criteria1:="A"
With ActiveSheet.Range("B11").Offset(1, 0).Resize(Rows.Count - ActiveSheet.Range("B11").Row, 1)
'first cell will be the the first cell of Areas(1)
Set firstCell = .SpecialCells(xlCellTypeVisible).Areas(1).Cells(1, 7)
'Get last cell by looping through areas until their total cell count reaches 4.
For Each area In .SpecialCells(xlCellTypeVisible).Areas
'first area may already contain more than N cells, in which case we just get its Nth cell and exit. "N" is rangeA, rangeB or rangeC
'If this is not the case, we add up rows.Count of each area until we get more than N, and when that happens,
'we get the cell of last area which is needed to get to N.
If CellCount + area.Rows.Count >= Range("v20").Value Then
Set lastCell = area.Cells(Range("v20").Value - CellCount, 0)
Exit For
End If
CellCount = CellCount + area.Rows.Count
Next
End With
'finally, from the firstCell and lastCell we can get the range of first N visible cells.
ActiveSheet.Range(firstCell, lastCell).Select
Selection.Copy
Application.Goto ActiveWorkbook.Sheets("Worksheet 2").Cells(8, 2)
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
''############# SELECTION B #################'
'##############################################
Application.Goto ActiveWorkbook.Sheets("DATA").Cells(11, 3)
ActiveSheet.Range("$A$11:$P$65").AutoFilter Field:=10, Criteria1:= _
"FILTER X"
ActiveSheet.Range("$A$11:$P$74").AutoFilter Field:=7, Criteria1:="B"
With ActiveSheet.Range("B11").Offset(1, 0).Resize(Rows.Count - ActiveSheet.Range("B11").Row, 1)
Set firstCell = .SpecialCells(xlCellTypeVisible).Areas(1).Cells(1, 7)
For Each area In .SpecialCells(xlCellTypeVisible).Areas
If CellCount + area.Rows.Count >= Range("V21").Value Then
Set lastCell = area.Cells(Range("V21").Value - CellCount, 0)
Exit For
End If
CellCount = CellCount + area.Rows.Count
Next
'End If
End With
ActiveSheet.Range(firstCell, lastCell).Select
Selection.Copy
Application.Goto ActiveWorkbook.Sheets("Worksheet 2").Cells(Range("v20").Value + 8, 2)
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("BASE DE DADOS").Activate
ActiveSheet.ShowAllData
'############# SELECTION C #######################'
'################################################
Application.Goto ActiveWorkbook.Sheets("DATA").Cells(11, 3)
ActiveSheet.Range("$A$11:$P$65").AutoFilter Field:=10, Criteria1:= _
"FILTER X"
ActiveSheet.Range("$A$11:$P$74").AutoFilter Field:=7, Criteria1:="C"
With ActiveSheet.Range("B11").Offset(1, 0).Resize(Rows.Count - ActiveSheet.Range("B11").Row, 1)
Set firstCell = .SpecialCells(xlCellTypeVisible).Areas(1).Cells(1, 7)
For Each area In .SpecialCells(xlCellTypeVisible).Areas
If CellCount + area.Rows.Count >= Range("V22").Value Then
Set lastCell = area.Cells(Range("V22").Value - CellCount, 0)
Exit For
End If
CellCount = CellCount + area.Rows.Count
Next
End With
ActiveSheet.Range(firstCell, lastCell).Select
Selection.Copy
Application.Goto ActiveWorkbook.Sheets("Worksheet 2").Cells(Range("v21").Value + Range("v20").Value + 8, 2)
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("BASE DE DADOS").Activate
ActiveSheet.ShowAllData
End Sub
Another observation is that when I run one selection alone it works perfectly fine (it can be one, two, three,... ten items). But when I run two selections (any combinations) it works until certain number of items, for rangeA and rangeB it works for 1 and 3 but it doesn't work for 3 and 3. In this last case it selects 3 items of A (correct) but only 1 item of B.
Also, it works for the three selections when the rangeA, rangeB and rangeC are respectively 3, 1, 1.
Any ideas?
Make the selection a function so you can re-use same code for each selection.
Option Explicit
Sub selectABC()
Dim wsData As Worksheet, ws2 As Worksheet, rngTarget As Range
Dim countA As Long, countB As Long, countC As Long, n As Long
With ThisWorkbook
Set wsData = .Sheets("DATA")
Set ws2 = .Sheets("worksheet 2")
End With
With wsData
'these are the cells where the number of rows I want
countA = 1 '.Range("v20").Value
countB = 4 ' .Range("v21").Value
countC = 4 ' .Range("v22").Value
End With
'selection A
Set rngTarget = ws2.Range("B8")
n = myselect(wsData, rngTarget, "FILTER X", "A", countA)
'selection B
Set rngTarget = rngTarget.Offset(n)
n = myselect(wsData, rngTarget, "FILTER X", "B", countB)
'selection C
Set rngTarget = rngTarget.Offset(n)
Call myselect(wsData, rngTarget, "FILTER X", "C", countC)
End Sub
Function myselect(wsData, rngTarget, f1, f2, maxrows) As Long
Dim rng As Range, a As Range, rngVisible As Range, rngCopy As Range
Dim lastrow As Long, n As Long, m As Long
With wsData
lastrow = .UsedRange.Row + .UsedRange.Rows.Count - 1
With .Range("A11:P" & lastrow)
.AutoFilter Field:=10, Criteria1:=f1 ' col J
.AutoFilter Field:=7, Criteria1:=f2 ' col G
Set rngVisible = .SpecialCells(xlCellTypeVisible)
If rngVisible Is Nothing Then
MsgBox " Error no data", vbCritical
Exit Function
End If
.AutoFilter
End With
'Debug.Print rngVisible.Address, f1, f2, lastrow
n = 0
m = 0
For Each a In rngVisible.Areas
For Each rng In a.Rows
' skip first headers
If n > 0 Then
If rngCopy Is Nothing Then
Set rngCopy = rng
Else
Set rngCopy = Union(rngCopy, rng)
End If
m = m + 1 ' row count
End If
n = n + 1
If n > maxrows Then Exit For
Next
If n > maxrows Then Exit For
Next
If rngCopy Is Nothing Then
' no data
Else
'Debug.Print rngCopy.Address
rngCopy.Copy
rngTarget.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
' remove selection shading
rngTarget.Parent.Activate
rngTarget.Select
End If
End With
myselect = m
MsgBox m & " rows copied for J=" & f1 & " G=" & f2
End Function

Incrementing a range

I have 135 rows of data in columns A to U
I am trying to write a script that will help me copy each column of data one under another to a clean worksheet.
Right now i wrote some code that will do it for the first two columns and i would prefer to have it done more automatically/dynamically instead of me copy pasting these two code blocks and altering the ranges
Range("A764:A897").Select
Selection.Copy
Sheets("New").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Sheets("Rom").Select
Range("B764:B897").Select 'id like to have this increment automaticaly
Selection.Copy
Sheets("New").Select
Range("A135").Select 'id like to have this increment automaticaly
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Try this. Adjust sheet name as necessary.
You can speed up the operation by directly transferring values rather then copying and pasting.
You could define the 134 as a constant so you only have to change once in the code rather than three times.
Sub x()
Dim rCopy As Range
Dim r As Long: r = 1
Set rCopy = Sheets("Name of source sheet").Range("A764").Resize(134) 'adjust sheet name
Do Until IsEmpty(rCopy(1))
Sheets("New").Cells(r, 1).Resize(134).Value = rCopy.Value
Set rCopy = rCopy.Offset(, 1)
r = r + 134
Loop
End Sub
Supposing your data in sheet “Rom” start at row 764:
Sub test()
Dim ws1, ws2 as string
Dim i, lr, lc as long
ws1 = “Rom”
ws2 = “New”
lc = sheets(ws1).cells(764,columns.count).end(xltoleft).column
For i = 1 to lc
lr = sheets(ws2).cells(Rows.count,1).End(xlUp).row + 1
sheets(ws1).range(cells(i, 764),cells(i,897)).Select
Selection.Copy
Sheets(ws2).cells(lr,1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Next
End sub
You can read in each column of data to an array and then paste it into your new column. In this way, you can perform any mutations needed on the data.
If you have 135 rows (always)
Dim ws As Worksheet, arr As Variant, myRange As Range, i As Integer, col As Integer, k As Integer
Set ws = ThisWorkbook.Sheets("Sheet1") ' or whatever your worksheet is
ReDim arr(1 To 135*22) ' 22 letters from A To U
k = 1
With ws
For col = 1 To 22
For i = 764 To 897
arr(k) = .Cells(col, i).Value2 ' if you need to do anything else here
k = k+1
Next i
Next col
End with
Set ws = ThisWorkbook.Sheets("New") 'or wherever this is going
With ws
.Range("A1").Resize(UBound(arr), 1).Value = Application.Transpose(arr)
End with

Paste values using range function in VBA

I'm using this code to paste values for a range but I started facing issues whenever my data is in a million or more line numbers, I wanted to break the range and run the same code in 4/5 parts (loops), can some one help me with it
Range("F14:J14").Select
Selection.Copy
With ActiveSheet
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
Range("F14:J14").Select
Selection.Copy
Range("f15:J" & RowCount).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("f15:J" & RowCount).Select
Selection.Copy
Range("f15:J" & RowCount).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
You are right, copying very large number of cells is problematic, so processing the data in blocks is a good idea.
That said, relying on Select and Copy PasteSpecial is also problematic.
I would suggest this alternative
Sub Demo()
Dim rSrc As Range
Dim rDst As Range
Dim rBlk As Range
Dim RowCount As Long
Dim CopyRowStart As Long
Dim CopyRowNum As Long
' Set number of rows to process at a time
CopyRowNum = 100000
' Set references to source and Destination ranges
With ActiveSheet
Set rSrc = .Range("F14:J14")
RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rDst = .Range("F15:J" & RowCount)
End With
' Copy data in blocks
CopyRowStart = 0
Set rBlk = rDst.Resize(CopyRowNum)
Do While CopyRowStart + CopyRowNum <= rDst.Rows.Count
' Copy formulas
rBlk.Formula = rSrc.Formula
' Convert to values
rBlk.Value = rBlk.Value
' Move to next block
If rBlk.Row + CopyRowNum + CopyRowStart - 1 > rDst.Row + rDst.Rows.Count - 1 Then
Exit Do
End If
Set rBlk = rBlk.Offset(CopyRowNum, 0)
CopyRowStart = CopyRowStart + CopyRowNum
DoEvents
Loop
' Copy remaining rows
If rBlk.Row + CopyRowNum <= rDst.Row + rDst.Rows.Count - 1 Then
Set rBlk = rBlk.Resize(rDst.Row + rDst.Rows.Count - rBlk.Row - CopyRowNum)
Set rBlk = rBlk.Offset(CopyRowNum, 0)
rBlk.Formula = rSrc.Formula
rBlk.Value = rBlk.Value
End If
End Sub
Note, the rather convoluted range size calculation are designed to avoid exceeding the size of the sheet, when the number of rows nears the end of the sheet (1,048,576 rows)

PasteSpecial not working

I have a sub which looks for values in the SolutionID column that match an array of values in one table, and then copies that over to the other.
However, I'm hitting an error with the .PasteSpecial method -
Object doesn't support this property or method
Does anybody know what I am doing wrong? Thanks.
Private Sub CopySolutions(ByRef SourceTable As ListObject, ByRef DestinationTable As ListObject, ByRef values() As String)
On Error Resume Next
Dim i, j As Integer ' Dummy for looping
'** Loop through all of the ID's to copy... *'
For i = LBound(values) To UBound(values)
With SourceTable.DataBodyRange
For j = 1 To .Rows.Count
If .Cells(j, 1).Value = values(i) Then
.Rows(j).Copy ' Copy the row in the SourceTable
Dim LastRow As Integer
LastRow = DestinationTable.Rows.Count ' Work out the number of rows in the DestinationTable
'** Check to see if the last row in the destination table is already empty '*
If DestinationTable.DataBodyRange.Cells(LastRow, 1).Value <> "" Or LastRow = 0 Then
DestinationTable.ListRows.Add AlwaysInsert:=True ' Insert a new row in to the DestinationTable
LastRow = LastRow + 1 ' Increment LastRow to take in to account the newly added row
End If
DestinationTable.DataBodyRange.Cells(LastRow, 1).Select ' Select the last row, column 1 in the Destination Table
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False ' Paste the copied row
Exit For ' Exit the For, there is no need to keep checking for matches
End If
Next
End With
Next
If Err.Number <> 0 Then
Call ErrorOutput("An error occured while copying your selected solutions.")
End If
On Error GoTo 0
WS.Range("Solution").Select ' Reselect the Solution cell range
End Sub
Best to avoid copy/paste alltogether:
Dim rngSrc as Range
'...
Set rngSrc = .Rows(j)
'...
DestinationTable.DataBodyRange.Cells(LastRow, 1). _
Resize(1, rngSrc.Columns.Count).Value = rngSrc.Value
Try this:
SourceTable.DataBodyRange.Rows(j).Copy DestinationTable.DataBodyRange.Range("A" & CStr(lastRow))
after you find last row of course. That way you don't have to use .Select

how do "relocate" cell values in a single column to a single row using Offset?

I am a bad VBA person. Please help me.
I want to relocate three values in a single column and put them in a single row using Offset. I need to flatten 3 rows of data into a single row of data.
Here is the code - it's very crude:
Sub Macro1()
'
' Macro1 Macro
'
'turn off display update
Application.ScreenUpdating = False
Dim CVFESUMMARY2(2000, 2000)
Dim MAXROW As Integer
Dim i As Integer
Dim r As Range
Dim x As Range
Dim y As Range
Dim z As Range
Set r = Range("BJ13:BJ512")
Set x = Range("BK13:BK512")
Set y = Range("BL13:BL512")
Set z = Range("BM13:BM512")
MAXROW = 300
'format "new" columns
Range("BK11").Select
ActiveCell.FormulaR1C1 = "NORM"
Range("BL11").Select
ActiveCell.FormulaR1C1 = "MIN"
Range("BM11").Select
ActiveCell.FormulaR1C1 = "MAX"
Columns("BJ:BM").Select
Selection.ColumnWidth = 12
'define the "COPY DATA FROM" starting cell location
Sheets("CVFESUMMARY2").Select
Range("BJ13").Select
'cycle through all of the rows in range r
For i = 1 To MAXROW
'copy "BJ13"
r.Select
Selection.Copy
'paste "value only" in column "BK13"
x.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'copy "BJ13+1"
Set r = r.Offset(1, 0)
r.Select
Selection.Copy
'paste "value only" in column "BL13"
y.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'copy "BJ13+2"
Set r = r.Offset(1, 0)
r.Select
Selection.Copy
'paste "value only" in column "BM13"
z.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'move active cell to "BJ13+4"
Set r = r.Offset(2, 0)
Set x = x.Offset(4, 0)
Set y = y.Offset(4, 0)
Set z = z.Offset(4, 0)
Next i
'turn on display update
Application.ScreenUpdating = True
End Sub
This somewhat works but it is adding values in rows +2 and +3 that I don't want; I think the looping is wrong. Thanks in advance!
Before
After
Your desired output, can the results be compacted? (all empty rows removed, leaving a block of data) or is there information in the columns before that its linked with?
Removing the extra rows wouldn't be much extra work.
With the following code (which I think does what you want) the MaxRows value is incorrect. The way it works this should be a MaxRecords ie: the number of groups of data you.
Sub Transpose()
Dim Position As Range
Dim Source As Range
Dim MaxRow As Integer
Dim Index As Integer
' set column titles
Range("BK11").Value2 = "NORM"
Range("BL11").Value2 = "MIN"
Range("BM11").Value2 = "MAX"
' set the width
Range("BJ:BM").ColumnWidth = 12
MaxRow = 512 ' see note below
Set Position = Range("BJ13") ' define the start position
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'For Index = 1 To MaxRow
Do
' create a range that contains your first 3 values
Set Source = Range(Position, Position.Offset(RowOffset:=2))
' copy it
Source.Copy
' paste and transpose the values into the offset position
Position.Offset(ColumnOffset:=1).PasteSpecial xlPasteValues, SkipBlanks:=False, Transpose:=True
' OPTIONAL - Clear the contents of your source range
Source.ClearContents
' re-set the position ready for the next iteration
Set Position = Position.Offset(RowOffset:=4)
'Next
Loop While Position.Row < RowMax
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Note: I've not used Select and Selection as they confuse me! Using Range() makes it simpler to know where you are imo.
Update I've included one that also compacts the output
Sub TransposeCompact()
Dim Position As Range
Dim Source As Range
Dim Destination As Range
Dim MaxRow As Integer
Dim Index As Integer
' set column titles
Range("BK11").Value2 = "NORM"
Range("BL11").Value2 = "MIN"
Range("BM11").Value2 = "MAX"
' set the width
Range("BJ:BM").ColumnWidth = 12
MaxRow = 512 ' see note below
' define the start position
Set Position = Range("BJ13")
' define the first output position
Set Destination = Position.Offset(ColumnOffset:=1)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'For Index = 1 To MaxRow
Do
' create a range that contains your first 3 values
Set Source = Range(Position, Position.Offset(RowOffset:=2))
' copy it
Source.Copy
' paste and transpose the values into the offset position
Destination.PasteSpecial xlPasteValues, SkipBlanks:=False, Transpose:=True
' OPTIONAL - Clear the contents of your source range
Source.ClearContents
' re-set the position ready for the next iteration
Set Position = Position.Offset(RowOffset:=4)
' increment the row on the output for the next iteration
Set Destination = Destination.Offset(RowOffset:=1)
'Next
Loop While Position.Row < RowMax
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Update 2
Your i variable used in the For Loop is not actually used, if your data is in rows 13 to 512 then the edits I've made to the code above should help.
The RowMax variable now will stop the macro when Position.Row goes beyond it.

Resources