I want to copy all filled cells starting from C5 to column F of a different worksheet.
I referred to another post: Excel - Combine multiple columns into one column
Modified the code based on my needs.
Sub CombineColumns()
Dim Range1 As Range, iCol As Long, Range2 As Range, Check As Range, wks As Worksheets
Set Range1 = wks("T(M)").Range(Cells(5, 3), Cells(Cells(5, 3).End(xlDown).Row, Cells(5, 3).End(xlToRight).Column))
Set Check = wks("csv").Range("F1")
If IsEmpty(Check.Value) = True Then
Set Range2 = Check
Else
LastRow = wks("csv").Range("F" & Rows.Count).End(xlUp).Row
Set Range2 = wks("csv").Cells(LastRow, 6).Offset(1, 0)
End If
For iCol = 3 To Range1.Columns.Count
wks("T(M)").Range(Cells(5, iCol), Cells(Range1.Columns(iCol).Rows.Count, iCol)).Copy
wks("csv").Range2.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next iCol
End Sub
But I kept getting the error message
"object doesn't support this method or property"
at the step of pasting. After I tried to qualify all the ranges, It says I didn't set the object variable.
Thank you so much for the help!
How about this?
Sub Transposes()
' Example just for hardcoded data
Dim inputRange As Range
Set inputRange = Sheets("Sheet1").Range("C5:F10").SpecialCells(xlCellTypeConstants)
Dim outputCell As Range
Set outputCell = Sheets("Sheet2").Range("A1")
Dim cell As Range
For Each cell In inputRange
Dim offset As Long
outputCell.offset(offset).Value = cell.Value
offset = offset + 1
Next cell
End Sub
Set the last row in ColumnF to be whatever you want, and if that changes dynamically, just use any one of the multiple techniques out there to find the last cell you need to copy/paste.
Related
I have a macro that prompts a user to select cells - these can be non adjacent - and paste them into a cell the user selects.
I found the macro somewhere online and it's great.
I am looking to add in font colour.
The cells being copied from are specific colours and I need to be able to maintain colour in the pasted cell.
Any help would be greatly appreciated! Thanks
Sub G()
Dim strFinal$
Dim cell As Range
Dim rngSource As Range
Dim rngArea As Range
Dim rngTarget As Range
Set rngSource = Application.InputBox("Select cells to merge", Type:=8)
Set rngTarget = Application.InputBox("Select destination cell", Type:=8)
For Each rngArea In rngSource
For Each cell In rngArea
strFinal = strFinal & cell.Value & " "
Next
Next
strFinal = Left$(strFinal, Len(strFinal) - 1)
rngTarget.Value = strFinal
End Sub
Edit: I have included an image showing what I am after - I have just done this manually to give a better description, but I am looking for a macro to do this with whichever cells the user selects. Thanks
This will copy the text from multiple cells into one cell, preserving the font color and size from each cell.
I've only used 2 non-contiguous cells in this example but it could easily be adapted to work with non-contiguous areas by adding a loop through Areas.
You could also add further code to copy over other types formatting, e.g. bold, italic etc, but I'm pretty sure that would need to be hard-coded.
Option Explicit
Sub CopyTextAndFont()
Dim cl As Range
Dim rngSrc As Range
Dim rngDst As Range
Dim chSrc As Characters
Dim chDst As Characters
Dim idxChr As Long
Dim cnt As Long
Set rngSrc = Range("B2, B7")
Set rngDst = Range("E5")
rngDst.Value = ""
For Each cl In rngSrc.Cells
rngDst.Characters.Insert rngDst.Value & cl.Value
Next cl
For Each cl In rngSrc.Cells
For idxChr = 1 To cl.Characters.Count
cnt = cnt + 1
Set chSrc = cl.Characters(idxChr, 1)
Set chDst = rngDst.Characters(cnt, 1)
chDst.Font.ColorIndex = chSrc.Font.ColorIndex
chDst.Font.Size = chSrc.Font.Size
Next idxChr
Next cl
End Sub
I need to fill in the table in the image by plugging in the values of mass and acceleration in C15 and C16 respectively and copying the corresponding value of force from C17 to the table.
Any help will be appreciated.
Sub NestedLoop()
Dim cell As Range, rgSource1 As Range, rgDestination1 As Range, cell2 As Range, rgSource2 As Range, rgDestination2 As Range
Set rgSource1 = ThisWorkbook.Worksheets("sheetname").Range("A1:A6")
Set rgSource2 = ThisWorkbook.Worksheets("sheetname").Range("B1:E1")
Set rgDestination1 = ThisWorkbook.Worksheets("SHEETNAME").Range("C15")
Set rgDestination2 = ThisWorkbook.Worksheets("SHEETNAME").Range("C16")
For Each cell In rgSource2[![enter image description here][1]][1]
For Each cell2 In rgSource1
rgSource1.Copy
rgDestination1.PasteSpecial xlPasteValues
Next cell2
rgSource2.Copy
rgDestination2.PasteSpecial xlPasteValues
Next cell
End Sub
Multiply First Row By First Column
By using an array, you can simplify the code and increase its efficiency.
The Code
Option Explicit
Sub Multiplication()
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
Dim Data As Variant: Data = rng.Value
Dim i As Long
Dim j As Long
For i = 2 To UBound(Data, 1)
For j = 2 To UBound(Data, 2)
Data(i, j) = Data(i, 1) * Data(1, j)
Next j
Next i
rng.Value = Data
End Sub
It's a little difficult to answer your question without knowing something a little closer to the actual problem. I don't know which parts I can modify and which ones I can't. For instance, iterating through the cells copying and pasting seems like the wrong way to go about it, but I don't know exactly what you're trying to accomplish, so I don't know how to suggest. Notice in the code given here I don't paste the answer back, I just figure out where it needs to go and write it there. I have added a sheet object to make range assignment easier, although you can accomplish this entire task without ever using a range at all. Further, I would just about always prefer to work in r1c1 than a1.
Sub NestedLoop()
Dim cell As Range, rgSource1 As Range, rgDestination1 As Range, _
cell2 As Range, rgSource2 As Range, rgDestination2 As Range
Dim this As Worksheet: Set this = ActiveSheet
Set rgSource1 = this.Range("A2:A6")
Set rgSource2 = this.Range("B1:E1")
Set rgDestination1 = this.Range("C15")
Set rgDestination2 = this.Range("C16")
Set rgResult = this.Range("c17")
For Each cell In rgSource2
For Each cell2 In rgSource1
cell.Copy
rgDestination1.PasteSpecial xlPasteValues
cell2.Copy
rgDestination2.PasteSpecial xlPasteValues
this.Cells(cell2.Row, cell.Column) = rgResult
Next
Next
End Sub
Here's the output:
I'm trying to look for the last row of data between column A and I and then duplicate the value to the row below which is empty.
Every time I run it, Excel crashes
Sub insert_row()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
LastRow = LastRow
Dim lastrow_start As String
Dim lastrow_end As String
lastrow_start = "A" & LastRow
lastrow_end = "I" & LastRow
Dim lastrowregion As String
lastrowregion = lastrow_start & ":" & lastrow_end
Dim lastrowrange As Range
Set lastrowrange = Range(lastrowregion)
Dim rng As Range
Set rng = Range(lastrow_start)
Do While (rng.Value <> "")
rng.Offset(1).insert
lastrowrange.Copy rng.Offset(1)
Set lastrowrange = rng.Offset(2)
Loop
End Sub
Is it just copying too much and causing a crash? It's only nine columns and they're all text apart from one cell which is a shape (button).
You are trying to set a String to a range object. To get the range use:
Set rng = Range(lastrowregion)
The Range you are getting is A2:I2. So your Do While will error because rng.Value is actually returning an Array. You could either loop through either the Range or the Array at that point if you intended on it being multiple cells.
If the goal is simply to copy the last row of data down one row then this method can be much simpler. You can simply set the Offset to equal the value of the last row. Since they are the same size it will just work.
To show this I used CurrentRegion but you could also do it with your A2:I2 Range.
Public Sub copyLastRowDown()
Dim region As Range
Set region = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
With region.Rows(region.Rows.Count)
.Offset(1).Value = .Value
End With
End Sub
Additional Notes
Use Option Explicit to ensure all variables are explicitly declared.
Declare and assign variables next to where they are going to be used, but place them in a reasonable place.
Do not use underscore case as this has special meaning with events and interfaces.
I have a data set, 10 columns wide, with an ever increasing number of rows.
In column C I have a set of features, e.g. "Search" that will have a few rows corresponding to it; ""Filter" that will have a few rows corresponding to it and so on. However, these could be in any order, so I could have some "Search" features and then some "Filter" features and then some more "Search" features...
I need to create a named range for selected cells in columns D:F where the value in C is the feature I require. This would be for example a named range called "T1" that goes from D3:F6 and maybe D71:F71 for all the "Search" features, but not the "Filter" features.
I have tried using Offset and Count in the Name Manager. But ideally, I need to use VBA in my already existing macro so I don't need to go in and change the Named Ranges every time a new row is added.
Ideally the code would be along the lines of...
If column C contains the word "Filter", make a named range for the three columns to the right of it, every time the word "Filter" occurs.
I used Offset and Count in the name manager:
=OFFSET(Features!$D$3, 0, 0, COUNTA(Features!$D$3:$D$9), COUNTA(Features!$D$3:$F$3))
Sub mySub()
Dim Features As Worksheet
Dim myNamedRange As Range
Dim myRangeName As String
Set Features = ThisWorkbook.Worksheets("Search")
If Range.("C") is "Search"
Set mRangeName= myWorksheet.Range("D:F")
myRangeName = "Search"
ThisWorkbook.Names.Add Name:=Search, RefersTo:=myNamedRange
End Sub
Any help would be greatly greatly appreciated. I hope I have clarified the problem enough.
If I understand correctly then you could try something like the following:
Sub test()
Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Name of your worksheet")
Set featuresRng = sht.Range(sht.Range("C1"), sht.Range("C" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
counter = 0 'this counter will help us avoid Union(Nothing, some range), which would give an error
For Each cell In featuresRng 'loop through the range of features
If cell.Value = "search" Then
counter = counter + 1
If counter = 1 Then
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
Else
Set rng = Union(rng, sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))) 'build the range
End If
End If
Next cell
Debug.Print rng.Address
sht.Names.Add "Something", rng
End Sub
The code above, loops through the range of features and whenever a cell whose value is "search" is found, it adds the corresponding D, E and F cells in a range. In the end you have a total range which you can name whatever you want.
For example, if you have the following set-up:
Then what you'll get is this:
So the resulting range address would be $D$1:$F$2,$D$8:$F$8,$D$10:$F$12,$D$15:$F$19
Now, if you want individual named ranges to be created every time the keyword is found you can modify the code accordingly like so:
Sub test2()
Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Name of your worksheet")
Set featuresRng = sht.Range(sht.Range("C1"), sht.Range("C" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
counter = 0
For Each cell In featuresRng
If cell.Value = "search" Then
counter = counter + 1
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
sht.Names.Add "Something" & counter, rng
End If
Next cell
End Sub
Hi this is my first post and i am newbie when it comes to VBA.
So i tried the last 6 hours to accomplish one task.
I already managed to get the code for the For each loop and it works and copies the value to the existing workbook. But i couldnt find out why it always copies the value to A2 and not further to A3/A4/A5 and so on .
I tried these piece of code " range = range + 1 " but i keep getting runtime errors and it still copies the values to A2 and overwrites it when it gets a new value from the loop.
I think its only a litte change needed but i cant figure it out. :(
Sub copie1()
Dim ws As Worksheet
Dim cell As Range
Dim targetsheet As Worksheet
Dim target As Range
Dim rngTemp As Range
Set wkba = ActiveWorkbook
Worksheets("cop1").Activate
LR = Cells(Rows.Count, "A").End(xlUp).Row
LT = Cells(Rows.Count, "X").End(xlUp).Row
Set rngTemp = Range("X2:X" & LT)
Workbooks.Open Filename:="C:\Users\path......."
Set targetsheet = Worksheets("Data")
Set target= targetsheet.Range("A1")
For Each cell In rngTemp
If cell > 0 Then
target.Offset(1, 0) = cell.Value
End If
target = target+1 '// is this right?
Next cell
End Sub
my goal is the loop through column X in a Workbook and copy every single data that is bigger than 0 ( because there are empty cells & cells with value 0)
and paste it in an existing workbook in range A2/A3/A4 and so on
You can't add the number one to a Range object.
Try replacing target = target+1 '// is this right? with:
Set target = target.Offset(1)
Does this resolve the problem?
SibSib1903, I have added below a simple example that you can easily adapt to your own requirements. It looks at all cell values in column A and any numeric value greater than zero is copied to column C starting in row 1. For example, if column A contains 45 rows with data, and only three of these rows have a numeric value greater than zero, these three values will copied in column C in the first three rows.
Public Sub copieTest()
Dim ws As Worksheet, cell As Range, rngX As Range
Dim tmpVal As Variant, counter As Long
Set ws = ThisWorkbook.Worksheets("cop1")
Set rngX = ws.Range("A1:A" & ws.Cells(ws.Rows.count, 1).End(xlUp).Row)
counter = 1
For Each cell In rngX
tmpVal = Val(Trim(cell.Value))
If tmpVal > 0 Then
ws.Range("C" & counter).Value = tmpVal
counter = counter + 1
End If
Next cell
Set rngX = Nothing: Set ws = Nothing
End Sub