Cycle value's in set cells - excel

I'm trying to make value's cycle with VBA (or another way).
The idea is that when the button is pressed that all values go forward, and the first one is moved to the back.
The cells with a value are C4, F4, I4, L4, O4, R4, U4, X4, AA4 and AD4 (always 2 cells in between.)
Also, not all 10 cells are always in use, sometimes there are only 2 or three, but other times you also have 7 or up to all 10.
Values are inputted the first time with a drop-down menu.
This is the macro I tried to use, this one just gives error 1004 :
Sub cycle()
Range("C4").Select
Selection.Copy
Range("AG15").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("F4:AD4").Select
Application.CutCopyMode = False
Selection.Copy
Range("C4").Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
IconFileName:=False
Range("AG15").Select
Selection.Copy
Sheets("Blad1").Select
Range("C5").Select
Range(Selection, Selection.End(xlRight)).Select
Selection.Copy
Range("AG15").Select
Application.CutCopyMode = False
Selection.ClearContents
End Sub
Added a screenshot as example with 4 values. Just keep in mind this can be up to 10 values.
I already tried to just copy the value of C4 to another cell, then select F4 till AD4, copy them end paste to C4, and then copy the one that was set aside, back to the first available of those 10 cells, starting from the left, but it messed up the whole excel, so deleted that one.

Cycle Range Values
Option Explicit
Sub CycleLeft()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Blad1")
Dim rg As Range: Set rg = ws.Range("C4,F4,I4,L4,O4,R4,U4,X4,AA4,AD4")
Dim currentCell As Range, previousCell As Range, CurrentValue, FirstValue
Dim IsNotFirst As Boolean
For Each currentCell In rg.Cells
CurrentValue = currentCell.Value
If Len(CStr(CurrentValue)) > 0 Then ' is not blank
If IsNotFirst Then
previousCell.Value = CurrentValue
Else
FirstValue = CurrentValue
IsNotFirst = True
End If
Set previousCell = currentCell
End If
Next currentCell
If Not previousCell Is Nothing Then previousCell.Value = FirstValue
End Sub

Related

Copy and paste values only after filtering data in vba [duplicate]

I have two sheets. One has the complete data and the other is based on the filter applied on the first sheet.
Name of the data sheet : Data
Name of the filtered Sheet : Hoky
I am just taking a small portion of data for simplicity. MY objective is to copy the data from Data Sheet, based on the filter. I have a macro which somehow works but its hard-coded and is a recorded macro.
My problems are:
The number of rows is different everytime. (manual effort)
Columns are not in order.
Sub TESTTHIS()
'
' TESTTHIS Macro
'
'FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B$2:$F$12").AutoFilter Field:=5, Criteria1:="hockey"
'Data Selection and Copy
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hockey").Select
Range("E3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("D3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("C3").Select
ActiveSheet.Paste
End Sub
Best way of doing it
Below code is to copy the visible data in DBExtract sheet, and paste it into duplicateRecords sheet, with only filtered values. Range selected by me is the maximum range that can be occupied by my data. You can change it as per your need.
Sub selectVisibleRange()
Dim DbExtract, DuplicateRecords As Worksheet
Set DbExtract = ThisWorkbook.Sheets("Export Worksheet")
Set DuplicateRecords = ThisWorkbook.Sheets("DuplicateRecords")
DbExtract.Range("A1:BF9999").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Cells(1, 1).PasteSpecial
End Sub
I suggest you do it a different way.
In the following code I set as a Range the column with the sports name F and loop through each cell of it, check if it is "hockey" and if yes I insert the values in the other sheet one by one, by using Offset.
I do not think it is very complicated and even if you are just learning VBA, you should probably be able to understand every step. Please let me know if you need some clarification
Sub TestThat()
'Declare the variables
Dim DataSh As Worksheet
Dim HokySh As Worksheet
Dim SportsRange As Range
Dim rCell As Range
Dim i As Long
'Set the variables
Set DataSh = ThisWorkbook.Sheets("Data")
Set HokySh = ThisWorkbook.Sheets("Hoky")
Set SportsRange = DataSh.Range(DataSh.Cells(3, 6), DataSh.Cells(Rows.Count, 6).End(xlUp))
'I went from the cell row3/column6 (or F3) and go down until the last non empty cell
i = 2
For Each rCell In SportsRange 'loop through each cell in the range
If rCell = "hockey" Then 'check if the cell is equal to "hockey"
i = i + 1 'Row number (+1 everytime I found another "hockey")
HokySh.Cells(i, 2) = i - 2 'S No.
HokySh.Cells(i, 3) = rCell.Offset(0, -1) 'School
HokySh.Cells(i, 4) = rCell.Offset(0, -2) 'Background
HokySh.Cells(i, 5) = rCell.Offset(0, -3) 'Age
End If
Next rCell
End Sub
When i need to copy data from filtered table i use range.SpecialCells(xlCellTypeVisible).copy. Where the range is range of all data (without a filter).
Example:
Sub copy()
'source worksheet
dim ws as Worksheet
set ws = Application.Worksheets("Data")' set you source worksheet here
dim data_end_row_number as Integer
data_end_row_number = ws.Range("B3").End(XlDown).Row.Number
'enable filter
ws.Range("B2:F2").AutoFilter Field:=2, Criteria1:="hockey", VisibleDropDown:=True
ws.Range("B3:F" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
Application.Worksheets("Hoky").Range("B3").Paste
'You have to add headers to Hoky worksheet
end sub
it needs to be .Row.count not Row.Number?
That's what I used and it works fine
Sub TransfersToCleared()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Application.Worksheets("Export (2)") 'Data Source
LastRow = Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A2:AB" & LastRow).SpecialCells(xlCellTypeVisible).Copy

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

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

If cell is empty, paste, Else, go to next blank cell and paste

Basically I just need excel to verify if Cell A1 is empty.
If A1 is empty, paste starting in A1.
If A1 is not empty, go down to the next blank cell in Column A, and paste there.
I am receiving an error : Application-defined or object-defined error on the Else part of the code.
If IsEmpty("A1") Then
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
Range("A1").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
I noticed two issues. (1) In the first line of code, you are testing whether the text "A1" is empty, not cell A1. So first change it so that the IsEmpty tests the cell A1. (2) As you add entries below A1, you need some method of counting how many rows down to go before pasting. Right now, your code starts at cell A1 and offsets by 1. This will only work once. The sample below counts how many rows are filled in the A column and then offsets by 1 row.
If IsEmpty(Range("A1")) Then
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Paste into Next Available Cell in Column
The Issues
Look at your code and imagine that cell A1 is not empty, but the rest of the cells in column A are. Then Range("A1").End(xlDown) will 'jump' to the bottom-most cell of column A: A1048576. You are additionally trying to do .Offset(1) which is not possible, hence the error.
Now again, look at your code and imagine that the range A1:A5 is not empty, but cell A6 is. Then Range("A1").End(xlDown).Offset(1, 0) will 'jump' to cell A6. But imagine that cell A7 is also not empty. Then you will possibly overwrite the value in cell A7.
Introducing a Function (A Quick Fix)
You could do:
Dim dCell As Range: Set dCell = RefFirstAvailableCell(Range("A1"))
dCell.PasteSpecial Paste:=xlPasteValues ' the rest were default values
Application.CutCopyMode = False
which uses the following function:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the First Available Cell in a column,
' i.e. creates a reference to the cell
' below the Last Non-Empty Cell in the Column Range
' spanning from the First Cell of a range ('rg')
' to the Bottom-Most Cell of the worksheet column.
' Remarks: If all cells in the Column Range are empty,
' it creates a reference to the First Cell.
' If the Bottom-Most Cell of the worksheet column
' is not empty, it returns 'Nothing'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefFirstAvailableCell( _
ByVal rg As Range) _
As Range
If rg Is Nothing Then Exit Function
With rg.Cells(1)
Dim wsrCount As Long: wsrCount = .Worksheet.Rows.Count
Dim fRow As Long: fRow = .Row
Dim lCell As Range
Set lCell = .Resize(wsrCount - fRow + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then
Set RefFirstAvailableCell = .Offset
Else
Dim lRow As Long: lRow = lCell.Row
If lRow = wsrCount Then
Exit Function
Else
Set RefFirstAvailableCell = .Offset(lRow - fRow + 1)
End If
End If
End With
End Function
Testing the Function
Instead of the End statement, the function uses the Range.Find method, which is more reliable. In fact, it 'normally' (think merged cells or similar) only fails if the worksheet is filtered.
The following procedure illustrates how to copy by assignment, which is 'cleaner' and more efficient (faster) than PasteSpecial when copying values only. It also introduces some additional fail-safes (Validate...).
To utilize it, copy both codes to a standard module (e.g. Module1) of a new workbook and make sure it contains Sheet1 and Sheet2 (code names). Run the procedure and see what has happened in both worksheets. Repeat the steps a few times and observe the changes in Sheet1. Play with it by changing the various constant values in this procedure's code (not the function).
Sub RefFirstAvailableCellTEST()
' Create a reference to the Source Range.
Dim srg As Range: Set srg = Sheet2.Range("B2:D5")
' Populate the Source Range.
Dim sCell As Range
Dim n As Long
For Each sCell In srg.Areas(1).Cells
n = n + 1
sCell.Value = n
Next sCell
' Write the number of source rows and columns to variables.
Dim rCount As Long: rCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
' Create a reference to the Destination Initial First Cell.
Dim diCell As Range: Set diCell = Sheet1.Range("A2")
' Create a reference to the Destination First Available Cell.
Dim dCell As Range: Set dCell = RefFirstAvailableCell(diCell)
' Validate First Available Cell.
If dCell Is Nothing Then Exit Sub
If dCell.Row > Sheet1.Rows.Count - rCount + 1 Then Exit Sub
If dCell.Column > Sheet1.Columns.Count - cCount + 1 Then Exit Sub
' Create a reference to the Destination Range.
Dim drg As Range: Set drg = dCell.Resize(rCount, cCount)
' Write the values from the Source Range to the Destination Range.
drg.Value = srg.Value
End Sub

Copy specified columns in particular order

I have 80 or so columns of data. I need just 21 columns.
In my output, I would like the 21 columns to be in a particular order. For example, I want the value from the cell AX2 from my source file to go to A2, BW2 to go to B2, etc.
The source data may differ from month to month and could have as little as 1 row of data or hundreds so I would like this to loop until no data is left.
I got a run time error 424 object required. I have only outlined the rules for two columns but will work on the rest when I get the proper set up.
Sub Macro1()
'
' Macro1 Macro
'
'
Sheet4.Select
Application.ScreenUpdating = False
row_count = 2
Do While Sheet2.Range("A" & row_count) <> ""
Range("AX2:AX1000").Select
Selection.Copy
ActiveWindow.ActivateNext
Range("A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.ActivateNext
Range("BW2:BW1000").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.ActivateNext
Range("B").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
x = x + 1
ActiveWindow.ActivateNext
ActiveSheet.Next.Select
ActiveSheet.Next.Select
Loop
End Sub
I hope I didn't go too far. Try this subscript, it asks you to select a workbook, it will open the workbook, copy column B2 to last used Row on Column B, and paste it on the first workbook. Make sure to rename the CopyFromSheet and CopyToSheet on the code. Please read each line and try to understand what it is doing. Let me know if any questions.
Sub CopyPaste()
Dim openFile As FileDialog, wb As Workbook, sourceWb As Workbook
Dim CopyTo As String, CopyFrom As String
Dim lastRow As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set openFile = Application.FileDialog(msoFileDialogFilePicker)
openFile.Title = "Select Source File"
openFile.Filters.Clear
openFile.Filters.Add "Excel Files Only", "*.xl*"
openFile.Filters.Add "All Files", "*.*"
openFile.Show
If openFile.SelectedItems.Count <> 0 Then
Set sourceWb = Workbooks.Open(openFile.SelectedItems(1), False, True, , , , True)
CopyFrom = "CopyFromSheetName"
CopyTo = "CopyToSheetName"
lastRow = sourceWb.Sheets(CopyFrom).Cells(Rows.Count, "B").End(Excel.xlUp).Row
sourceWb.Sheets(CopyFrom).Range("B2:B" & lastRow).Copy 'You can copy this Row and the Next and add as many as you want to copy the Columns Needed
wb.Sheets(CopyTo).Range("B1").PasteSpecial xlValues
Application.CutCopyMode = xlCopy
Else
MsgBox "A file was not selected"
End If
Application.ScreenUpdating = True
End Sub
I suggest you separate the copy logic from the setup of which columns to copy. That way it will be much easier to manage the setup.
In this code I have hard coded to Columns Pairs. Alternatively, you could put that data on a sheet and read it in.
Sub Demo()
'declare all your variables
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rSource As Range
Dim rDest As Range
Dim CP() As Variant 'Column Pairs array
Dim idx As Long
'Set up an array of Source and Destination columns
ReDim CP(1 To 21, 1 To 2) 'Adjust size to suit number of column pairs
CP(1, 1) = "AX": CP(1, 2) = "A"
CP(2, 1) = "BW": CP(2, 2) = "B"
'and so on
' Source and Destination don't have to be in the same Workbook
' This code assumes the Source (and Destination) worksbooks are already open
' You can add code to open them if required
' If the data is in the same book as the code, use ThisWorkbook
' If the data is in a different book from the code,
' specify the book like Application.Workbooks("BookName.xlsx")
' or use ActiveWorkbook
'Update the names to your sheet names
Set wsSource = ThisWorkbook.Worksheets("SourceSheetName")
Set wsDest = ThisWorkbook.Worksheets("DestSheetName")
' Notice that form here on the code is independent of the Sheet and Column names
'Loop the column pairs array
For idx = 1 To UBound(CP, 1)
'if the entry is not blank
If CP(idx, 1) <> vbNullString Then
'Get reference to source column cell on row 2
Set rSource = wsSource.Columns(CP(idx, 1)).Cells(2, 1)
'If that cell is not empty
If Not IsEmpty(rSource) Then
'If the next cell is not empty
If Not IsEmpty(rSource.Offset(1, 0)) Then
'extend range down to first blank cell
Set rSource = wsSource.Range(rSource, rSource.End(xlDown))
End If
'Get a reference to the destination range, from row 2, same size as source
Set rDest = wsDest.Columns(CP(idx, 2)).Cells(2, 1).Resize(rSource.Rows.Count)
'Copy the values
rDest.Value = rSource.Value
End If
End If
Next
End Sub

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