I have built a few templates of differing rows (same columns) that I want to be pulled in and inserted based on changing a cell value.
So if you change A1 to value of temp1 it will insert rows/values of the "temp1" template array (100 rows) from another sheet, and if you change A101 to value of temp2 it will insert rows/values of the "temp2" template array (25 rows) from another sheet.
You asked to insert rows, not to clean up the sheet and then paste the rows.
The attached Worksheet_Change even code is an example of how to accomplish what you are specifying ...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim srcSht As Worksheet
Dim lstRow As Long, lstCol As Long
Dim srcRng As Range
Dim tarRng As Range
If Target.Address = "$A$1" Then
Set tarRng = ActiveSheet.Range("A2")
If Target.Value = "temp1" Then Set srcSht = Worksheets("Shtemp1")
If Target.Value = "temp2" Then Set srcSht = Worksheets("Shtemp2")
If srcSht Is Nothing Then Exit Sub
lstRow = srcSht.Range("A" & srcSht.Rows.Count).End(xlUp).Row
Set srcRng = srcSht.Range(srcSht.Cells(1, 1), srcSht.Cells(lstRow, 1))
srcRng.EntireRow.Copy
tarRng.EntireRow.Insert shift:=xlDown
End If
Set tarRng = Nothing
Set srcRng = Nothing
Set srcSht = Nothing
End Sub
Below is a screen cap of Shtemp1 ...
... and a screen cap of Shtemp2 ...
When "temp1" is typed into Cell A1 of the worksheet with the code attached, you get this ...
... changing Cell A1 to "temp2", you get this ...
Related
I want to copy the value given in column 1 (Desc) into another worksheet (but in the next blank row) using worksheet calculate event, when the user enter data in the input columns (B,C,D) provided that the output value (derived using a logical condition linked to input columns) is matching with the input value.
Below is a sample table:
I used below code to get that, but since have little understanding it didnt work out well.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsSource As Worksheet, wsDest As Worksheet
Dim srcR, srcR1 As Range
Set wsSource = Target.Worksheet
Set wsDest = ThisWorkbook.Sheet2
Set srcR = wsSource.Range("B:B, C:C, D:D")
Set srcR1 = wsSource.Range("E:E, F:F, G:G")
If Not Intersect(Target, srcR) Is Nothing And Target.Count = 1 And srcR.value = srcR1.value Then
Dim intLastRow As Long
intLastRow = wsDest.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
wsDest.Cells(intLastRow + 1, "A") = wsSource.Cells(Target.Row, 1)
End If
End Sub
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 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.
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
I have code (see below) which assigns dims, sets the range for each, then opens new workbook, finds first empty row and inserts the values into each offset column appropriately. What I now need to do, somehow! is also copy the cell color and place it in the new workbook too for each DIM. Anyone have any ideas based on this working script? (There are actually 29 DIM's set but only included one for ease of use.)
Private Sub CommandButton1_Click()
Dim itemLast As String
Dim myAuthorization As Workbook
Worksheets("Sheet2").Select
itemLast = Range("C10")
Set myAuthorization = Workbooks.Open("M:\authorizations.xlsm")
Worksheets("Sheet1").Select
Worksheets("Sheet1").Range("A1").Select
RowCount = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count
With Worksheets("Sheet1").Range("A1")
.Offset(RowCount, 0) = itemLast
End With
myAuthorization.Save
myAuthorization.Close
End Sub
Untested:
Private Sub CommandButton1_Click()
Dim rngFrom As Range, rngTo As Range
Dim myAuth As Workbook
Set myAuth = Workbooks.Open("M:\authorizations.xlsm")
Set rngFrom = ThisWorkbook.Worksheets("Sheet2").Range("C10")
Set rngTo = myAuth.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
rngTo.Value = rngFrom.Value
rngTo.Interior.Color = rngFrom.Interior.Color
myAuth.Close SaveChanges:=True
End Sub
To explain:
Set rngTo = myAuth.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
We want to find the first empty row on that sheet, looking in Col A (and working from the bottom of the sheet upwards)
Cells(Rows.Count, 1)
is starting on the last row of the sheet in Col A (Col 1). From there
End(xlUp)
is the same as pressing Ctrl+Up - it will take you up to the first occupied cell in that column. From there
Offset(1, 0)
moves that position by 1 row down (and zero columns across)