Working on some code to copy an active range of cells in column E and then paste the range (starting from the same row) into every nth column. The copy selection part works fine but I can't get the right syntax for the pasting part. I tried setting the cells equal to the selection as I wasn't sure on appropriate syntax to paste values of a selection. Any help/guidance is appreciated! Here is my code:
Sub Sco__copy()
Dim cpval As Range
Dim lastRow As Long
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "E").End(xlUp).Row
.Range("E163:E" & lastRow).Select
Set cpval = Selection
End With
For colx = 12 To 1000 Step 7
Cells(lastRow, colx).Value = cpval
Next
End Sub
Try this:
Sub Sco__copy()
Dim cpval As Range
Dim lastRow As Long
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "E").End(xlUp).Row
Set cpval = .Range("E163:E" & lastRow)
For colx = 12 To 1000 Step 7
.Range(.Cells(163, colx), .Cells(lastRow, colx)).Value = cpval.Value
Next
End With
End Sub
The idea is that when assigning values, the target range needs to be the same size as the original.
So by extending the with statement and creating a range the same size it should place the cells in every 7th column.
Related
top part of the worksheet
very new to VBA and I'm trying to develop a macro to do some formatting. I have a variable amount of data (row wise, columns are the same) in my worksheet. After the last row of data, there are a bunch of blank white rows, and at the very bottom is a grey-shaded row. I want to hide all of the blank white rows in the middle, so that the grey-shaded row is then right under my last row with data in it.
Here is the code I have so far (note: Column I is the last column). Any help would be greatly appreciated. Right now, I am getting a "type mismatch" error for the "BeforeFinalRow = finalRow - 1" part, but I'm sure there's a lot more that's wrong with this code. Thanks in advance!
Sub hide_rows()
Dim BelowUsedData As Long
BelowUsedData = Cells(Rows.Count, 2).End(xlUp).Row + 1
Dim RowBelowUsedData As Range
RowBelowUsedData = Range("A" & BelowUsedData, "I" & BelowUsedData)
Range("A1").Select
Selection.End(xlDown).Select
Dim finalRow As Range
finalRow = Range(Selection, Selection.End(xlToRight))
Dim BeforeFinalRow As Long
BeforeFinalRow = finalRow - 1
Rng = Range(Cells(RowBelowUsedData, "A"), Cells(BeforeFinalRow, "I")).Select
Selection.EntireRow.Hidden = True
End Sub
You could simplify this and hard code your bottom border cell into the code (Just change the value of BottomBorder in code)
Option Explicit
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LRow As Long, BottomBorder As Long
LRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(1).Row
BottomBorder = 1006 'Change this if your bottom border changes
ws.Range(ws.Cells(LRow, 1), ws.Cells(BottomBorder, 1)).EntireRow.Hidden = True
End Sub
Another option is to use a WorkSheet_Change Event. This will only work if you are inputting data in one entry (row) at a time.
To implement: Hide all unused rows with the exception of 1! So if your last used cell is B4, hide B6 down to BottomBorder which will leave B5 as a white blank row where your next entry will go. Then paste the below code in the worksheet in VBE. Every time an entry is made in your blank row (B5) here, the macro will insert a new row keeping your current format.
This is dynamic so it will also look at the next blank row (After B5, B6 will be your new target row)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LRow As Long
LRow = Range("B" & Rows.Count).End(xlUp).Offset(1).Row
Application.EnableEvents = False
If Target.Row = LRow - 1 And Target.Column = 2 Then
Range("A" & LRow + 1).EntireRow.Insert (xlShiftUp)
End If
Application.EnableEvents = True
End Sub
On the photo it looks like the rows are not hidden but grey. The below code will find where the color changes and hide those white rows between the last row with data and the first grey cell:
Sub hide_rows()
Dim rngData As Range
Dim rngFirstCelltoHide As Range
Dim rngLastWhite As Range
Set rngData = Range("B1").CurrentRegion
Set rngFirstCelltoHide = rngData.Cells(rngData.Rows.Count, 1).Offset(1, 0)
Set rngLastWhite = rngFirstCelltoHide
Do Until rngLastWhite.Interior.Color <> rngLastWhite.Offset(1, 0).Interior.Color
Set rngLastWhite = rngLastWhite.Offset(1, 0)
Loop
Range(rngFirstCelltoHide, rngLastWhite).EntireRow.Hidden = True
End Sub
finalRow is a range object. That is why you get 'type error' when you subtract 1 from it. Declare the variable as long and assign row number to it as follows:
finalRow = Range(Selection, Selection.End(xlToRight)).Row
I have a excel which has multiple rows and columns and range of column values differ for each row.
Need a macro which will delete all cells in a row except first and last in each row and paste the last value next to first value.
Tried the below script:
Sub test()
Dim sh As Worksheet
Dim IDS As range
Dim ID As range
Set sh = ThisWorkbook.Sheets("Sheet1")
Set IDS = ActiveSheet.range("A2", range("A1").End(xlDown))
For Each ID In IDS
Dim b As Integer
Dim k As Integer
k = sh.range("ID", sh.range("ID").End(xlToRight)).Columns.Count
b = k - 1
range(ID.Offset(0, 0), ID.Offset(0, "b")).Select
Selection.ClearContents
Next ID
End Sub
This is a little different approach but should help.
Also, it is generally not best to declare variables in a loop as you do with b & k just fyi
Sub test()
Dim sh As Worksheet
Dim row As Integer
Dim lastCol As Integer
Set sh = ThisWorkbook.Sheets("Sheet1")
For row = 2 To sh.Cells(Sheets(1).Rows.Count, "A").End(xlUp).row
lastCol = sh.Cells(row, Columns.Count).End(xlToLeft).Column
sh.Range("B" & row).Value = sh.Cells(row, lastCol).Value
sh.Range(sh.Cells(row, 3), sh.Cells(row, lastCol)).ClearContents
Next
End Sub
Best of luck
I'd go as follows:
Sub test()
Dim cell As Range
With ThisWorkbook.Sheets("Sheet1") ' reference relevant sheet
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' loop through referenced sheet column A cells from row 2 down to last not empty one
With .Range(cell, .Cells(cell.Row, .Columns.Count).End(xlToLeft)) ' reference referenced sheet range spanning from current cell to last not empty one in the same row
If .Count > 2 Then ' if referenced range has more then 2 cells
cell.Offset(, 1).Value = .Cells(1, .Count).Value ' store last cell value next to the current one
.Offset(, 2).Resize(, .Columns.Count - 1).ClearContents 'clear all cells right of current one
End If
End With
Next
End With
End Sub
You can use Range.Delete Method (Excel)
range(ID.Offset(0, 0), ID.Offset(0, b)).Delete Shift:=xlToLeft
the thing is I want to copy a certain column but I want to only copy data on a specific cell and get the data below it.
Let say for example, I want to copy Cell C5 and below, this will disregard C1 to C4. Is this possible?
Further to my comments below your question, here is one way. This will work in all scenarios. Whether you have blank cells or not...
Option Explicit
Sub CopyCells()
Dim ws As Worksheet
Dim rng As Range
Dim sRow As Long, lRow As Long
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
sRow = 5 '<~~ Starting row
With ws
'~~> Find last row in Col C
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
'~~> If the last row < Start Row
If lRow < sRow Then
MsgBox "Start Row cannot be greater then last row"
Else
'~~> Create your range
Set rng = .Range("C" & sRow & ":C" & lRow)
'~~> Copy
rng.Copy
'
' Do what you want with copied data
'
End If
End With
End Sub
Sheet1.Columns(3).Resize(Sheet1.Columns(3).Rows.Count - 4).Offset(4).Select
This will select entire C column but first 4 cells. It simply take column 3, resize it to subtract first 4 cells and offset the starting cell 4 cell below and select that range.
If your range is defined then code could be more optimized.
EDIT for sample code:
Sub copyCells()
Dim sht As Worksheet
Dim rngStart As Range
Dim rng As Range
Set sht = Sheet1
Set rngStart = sht.Cells(5, 3) ' this is C5
rngStart.Select
Set rng = rngStart.Resize(rngStart.End(xlDown).Row - rngStart.Row + 1)
rng.Copy Sheet2.Cells(1, 1) ' copy where you need
End Sub
This will copy a entire column (with data) from selection, just paste it wherever you want.
Sub CopyColumnFromSelected()
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
End Sub
Or (Ctrl + Shift + down arrow) <--- from your desired cell and Ctrl+C ;)
This is my first time to code in VBA.
I have several worksheets in a file and they are in order by dates.
So what I am trying to do is to collect data sets in a worksheet if they have the same period of time.
date1 value1
date2 value2
date3 value3
Since they are in order I just compare the first date values and if they are different it moves on to the next worksheet. If they are the same then copy the value and do the same process until it reaches the last worksheet.
However it copies one worksheet fine but after that Excel freezes.
I would be appreciated if you find any errors or give me other suggestions to do it.
Following is my code:
Sub matchingStock()
Dim sh1 As Worksheet, sh2 As Worksheet
' create short references to sheets
' inside the Sheets() use either the tab number or name
Set sh1 = Sheets("combined")
Dim col As Long
'since first column is for Tbill it stock price should place from the third column
col = 3
Dim k As Long
'go through all the stock worksheets
For k = Sheets("WLT").Index To Sheets("ARNA").Index
Set sh2 = Sheets(k)
' Create iterators
Dim i As Long, j As Long
' Create last rows values for the columns you will be comparing
Dim lr1 As Long, lr2 As Long
' create a reference variable to the next available row
Dim nxtRow As Long
' Create ranges to easily reference data
Dim rng1 As Range, rng2 As Range
' Assign values to variables
lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
Application.ScreenUpdating = False
' Loop through column A on sheet1
For i = 2 To lr1
Set rng1 = sh1.Range("A" & i)
' Loop through column A on sheet1
For j = 2 To lr2
Set rng2 = sh2.Range("A" & j)
' compare the words in column a on sheet1 with the words in column on sheet2
'Dim date1 As Date
'Dim date2 As Date
'date1 = TimeValue(sh1.Range("A3"))
'date2 = TimeValue(sh2.Range("A3"))
sh1.Cells(1, col).Value = sh2.Range("A1").Value
' find next empty row
nxtRow = sh1.Cells(Rows.Count, col).End(xlUp).Row + 1
' copy the word in column A on sheet2 to the next available row in sheet1
' copy the value ( offset(0,1) Column B ) to the next available row in sheet1
sh1.Cells(nxtRow, col).Value = rng2.Offset(0, 6).Value
'when the date is different skip to the next worksheet
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
'sh3.Rows("1:1").Delete
Else
GoTo Skip
End If
Skip:
col = col + 1
Next k
End Sub
I cannot identify a specific error so this is a list of suggestions that may help you identify the error and may help improve your code.
Suggestion 1
Do you think the Else block of If-Then-Else-End-If is compulsory?
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
:
Else
GoTo Skip
End If
Skip:
is the same as:
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
:
End If
Suggestion 2
I do not like:
For k = Sheets("WLT").Index To Sheets("ARNA").Index
The value of property Index for a worksheet may not what you think it is. This may not give you the set or sequence of worksheets you expect. Do you want every worksheet except "Combined"? The following should be more reliable:
For k = 1 To Worksheets.Count
If Worksheets(k).Name <> sh1.Name Then
:
End If
Next
Suggestion 3
You use:
.Range("A" & Rows.Count)
.Range("A3")
.Cells(1, col).Value
.Cells(Rows.Count, col)
rng2.Offset(0, 6)
All these methods of identifying a cell or a range have their purposes. However, I find it confusing to use more than one at a time. I find .Cells(row, column) and .Range(.Cells(row1, column1), .Cells(row2, column2)) to be the most versatile and use them unless there is a powerful reason to use one of the other methods.
Suggestion 4
I cannot decypher what this code is attempting to achieve.
You say: "I have several worksheets in a file and they are in order by dates. So what I am trying to do is to collect data sets in a worksheet if they have the same period of time."
If you have set Worksheet("combined").Range("A3").Value to a particular date and you want to collect data from all those sheets with the same value in cell A3 then the outer For-Loop and the If give this effect. But if so, if does not matter how the worksheets are ordered. Also you start checking cell values from row 2 which suggests row 3 is a regular data row.
The outer loop is for each worksheet, the next loop is for each row in "combined" and the inner loop is for each row in the worksheet selected by the outer loop. The middle loop does not appear to do anything but set rng1 which is not used.
Perhaps you can add an explanation of what you are trying to achieve.
Suggestion 5
Are you trying to add an entire column of values from the source worksheets to "Combined". The macro below:
Identifies the next free row in column A of "Combined"
Identifies the last used row in column A of "Sheet2"
Assumes the first interesting row of "Sheet2" is 2.
Adds the entire used range of column A of "Sheet2" (complete with formatting) to the end of "Combined"'s column A in a single statement.
This may demonstrate a better way of achieving the effect you seek.
Sub Test()
Dim RngSrc As Range
Dim RngDest As Range
Dim RowCombNext As Long
Dim RowSrcFirst As Long
Dim RowSrcLast As Long
With Worksheets("Combined")
RowCombNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Set RngDest = .Cells(RowCombNext, "A")
End With
With Worksheets("Sheet2")
RowSrcFirst = 2
RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
Set RngSrc = .Range(.Cells(RowSrcFirst, "A"), .Cells(RowSrcLast, "A"))
End With
RngSrc.Copy Destination:=RngDest
End Sub
I am trying to paste a formula next to range of cells, but only the one's that contains a value, the script must loop until the next cell in the range is empty. For instance Sheet 1 Column A contains date until row 12, then I would like to paste a formula in column D2:D12 Regards
Like this?
Option Explicit
Sub Sample()
Dim lastRow As Long, i As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
With ws
For i = 1 To lastRow
If Len(Trim(.Range("A" & i).Value)) <> 0 Then _
.Range("D" & i).Formula = "YOUR FORMULA"
Next i
End With
End Sub
As you are looking down to the first blank cell then you can avoid a loop and use
The code includes a test to make sure that the code doesn't proceed if all of column A is blank - ie if the range from A1 down extends to the bottom of the sheet and A1 is blank
This code adds a sample formula linking each cell in column D to the respective row in column B
Sub FillData()
Dim rng1 As Range
Set rng1 = Range([a1], [a1].End(xlDown))
If Not (rng1.Rows.Count = Rows.Count And Len([a1].Value) = 0) Then rng1.Offset(0, 3).FormulaR1C1 = "=RC2"
End Sub
I like Sid's beginning, but once you have the range of rows, you can insert the formula into column D all at once, without looping, several ways, here's one:
Option Explicit
Sub AddFormula()
Dim LR As Long
LR = Range("A" & Row.Count).End(xlUp).Row
Range("D2:D12").Formula = "=A2 + 7" 'just an example of a formula
End Sub
Try this:
Range("A:A").SpecialCells(2).Areas(1).Offset(, 3).Formula = "MyFormula"
This is a simple solution that is built into Excel, as long as you don't want to copy to the first blank, jump over the blank, then continue copying:
Enter the formula in the first cell of your range, and as long as it is in the column directly to the right or left of your range of filled cells, simply double-click the black box handler in the bottom right-hand corner of the cell. That will automatically copy your formula down to the last non-empty cell of the range.