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
Related
I filtered out some of my data using the Autofilter function. As a result, the filtered data consists of a non-contiguous range of cells.
Consequently, for example, when I use the CountIfs function to count the number of 03-In Analysis from Column C that belong to 07-customer noticed from column A, the CountIfs function counts the unfiltered data.
Filtered Data
When I use SpecialCells(xlCellTypeVisible), I get an error due to the non-contiguous range of cells.
Dim sh, ws As Worksheet
Dim count
Dim range1, range2 As Range
Set range1 = ws.Range("A2:A297")
Set range2 = ws.Range("C2:C297")
count = WorksheetFunction.CountIfs(range1, "07-customer noticed", range2, "03-In Analysis")
sh.Range("A1") = count
Arrays work faster for me than worksheet functions.
I tried and tested the code below and it works for me.
Option Explicit
Private Sub Test()
Dim sRange$
Dim count&, iLastUsedRow&, iRow&
Dim aData As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("B")
With ws
'last used row of data on this sheet
iLastUsedRow = .Range("A" & Rows.count - 1).End(xlUp).Row
'cells containing data
sRange = "A2:C" & iLastUsedRow
'transferring data to array
aData = .Range(sRange)
End With
For iRow = 1 To UBound(aData)
If Range_IsVisibleInWindow(ws.Range("A" & iRow + 1)) Then
If aData(iRow, 1) = "07-customer noticed" And aData(iRow, 3) = "03-In Analysis" Then
count = count + 1
End If
End If
Next
End Sub
I copied this function from here and upvoted their answer. You may want to thank them too in this way, if this works for you?
Function Range_IsVisibleInWindow(ByVal target As Excel.Range) As Boolean
' Returns TRUE if any cell in TARGET (Range) is visible in the Excel window.
'
' Visible means (1) not hidden, (2) does not have row height or column width of
' zero, (3) the view is scrolled so that the Range can be seen by the user at
' that moment.
'
' A partially visible cell will also return TRUE.
If target Is Nothing Then
' Parameter is invalid. Raise error.
Err.Raise 3672, _
"Range_IsVisibleInWindow()", _
"Invalid parameter in procedure 'Range_IsVisible'."
Else
' Parameter is valid. Check if the Range is visible.
Dim visibleWinLarge As Excel.Range
Dim visibleWinActual As Excel.Range
On Error Resume Next
Set visibleWinLarge = Excel.ActiveWindow.VisibleRange ' active window range -INCLUDING- areas with zero column width/height
Set visibleWinActual = visibleWinLarge.SpecialCells(xlCellTypeVisible) ' active window range -EXCLUDING- areas with zero column width/height
Range_IsVisibleInWindow = Not Intersect(target, visibleWinActual) Is Nothing ' returns TRUE if at least one cell in TARGET is currently visible on screen
On Error GoTo 0
End If
End Function
I am trying to find a way to replace all values on the second tab of an Excel workbook with values from a table in a different tab 1 cell to the right of the corresponding value. On Sheet1 there are 2 columns. 1 is called ID and the second is called New ID. On Sheet2 there is a column called ID. I am looking for a way so that when I run a macro the values on Sheet2 will be replaced by the corresponding New ID from Sheet1. For example, on Sheet2 the first ID is ABC. On Sheet1 the corresponding New ID value for ABC is 123. I'd like the VBA script to replace all ABCs on Sheet2 with 123. I need this for varying amounts of data.
Sheet1
Sheet2
So far I've tried the following but it won't change the cells
Sub Test1()
Dim N As Long, L As Long
Dim rLook As Range
Sheets("Sheet1").Select
N = Cells(Rows.Count, "A").End(xlUp).Row
aryA = Range("A2:A" & N)
aryB = Range("B2:B" & N)
Sheets("Sheet2").Select
Set rLook = Range("A2:A" & N)
For L = 1 To N
rLook.Replace aryA(L, 1), aryB(L, 1)
Next L
End Sub
When I run the macro it only changes the same number of rows as Sheet1 so I am left with the following:
Result
After I run this I get an error that says subscript is out of range.
Your error is basically that you reuse N, which is the number of rows from sheet1 to define the range on sheet2.
So my advise is to use more explicit names for variables that explain what the variable "contains".
Furthermore if you don't use the implicit Cells(xxx) but the explicit one Thisworkbook.Worksheets("Sheet1") you can omit the selection of the sheets (and by that reduce the possibility for errors referencing the wrong range).
Plus: you can read both columns of sheet1 into one array
Option Explicit
Public Sub updateSheet2IDs()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Dim wsTarget As Worksheet
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
Dim cntRowsSheet1 As Long
Dim arrSource As Variant
With wsSource
cntRowsSheet1 = .Cells(.Rows.Count, "A").End(xlUp).Row
'array includes both columns: arrsource(1,1) = A2, arrsource(1,2) = B2
arrSource = .Range("A2:B" & cntRowsSheet1)
End With
Dim cntRowsSheet2 As Long, rgTarget As Range
With wsTarget
cntRowsSheet2 = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rgTarget = .Range("A2:A" & cntRowsSheet2)
Dim i As Long
For i = 1 To UBound(arrSource, 1) 'ubound gives you the upper bound of the array
rgTarget.Replace arrSource(i, 1), arrSource(i, 2)
Next
End With
End Sub
You could omit the whole "cntRows"-stuff by using currentregion - which returns the area around one cell that is surrounded by empty rows and columns (see https://learn.microsoft.com/en-us/office/vba/api/excel.range.currentregion).
That means that wsSource.Range("A1").CurrentRegionwill return all cells until the first empty row and until the first empty column - I assume this is exactly what your are looking for. The same for sheet2 as well.
To omit the first row, you can use offset:
set rgTarget = wsTarget.Range("A1").CurrentRegion.Offset(1)
The code then looks like
Option Explicit
Public Sub updateSheet2IDs()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Dim wsTarget As Worksheet
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
'array includes both columns: arrsource(1,1) = A2, arrsource(1,2) = B2
Dim arrSource As Variant
arrSource = wsSource.Range("A1").CurrentRegion.Offset(1)
Dim rgTarget As Range
Set rgTarget = wsTarget.Range("A1").CurrentRegion.Offset(1)
Dim i As Long
For i = 1 To UBound(arrSource, 1) 'ubound gives you the upper bound of the array
rgTarget.Replace arrSource(i, 1), arrSource(i, 2)
Next
End Sub
I have a large sheet of data:
Updated Data
where i need to copy only a speacific part of this data to another worksheet:
The data i need to copy is always 4 cells wide however can be at any row and column. The first column cell at the top will allways be the same text value and i need to copy then from that found cell, 4 cells across to the right and then down to the cells are empty. All subsequent ranges after the first will use the same columns have several empty cells bother above and below each range needed. The macro will be run using a "button" so doesn't need to be checking the value of the cell all the time. The images are simplified versions of the data but are very accurate. 0 is used to show data surrounding range, HELLO is the data inside the range and INT_EXT_DOOR is my searched for cell value which can be in any column between data sets but will be the same inside each data set. The first range always starts at row 2.
Each range has to be numbered, defined by another worksheets cell value. For example, if my cell value is 1 i need it to copy range 1, if my value is 2 copy range 2 ect.
I have been trying to no luck to get anything that works like needed and would appreciate any help, thanks.
Test the next function, please:
Private Function testReturnBlock(strBlock As String, blkNo As Long)
Dim sh As Worksheet, ws As Worksheet, lastRow As Long, searchC As Range
Dim rng As Range
Set sh = ActiveSheet ' use here your sheet to be processed
Set ws = Worksheets("Return") 'use here your sheet where the data will be returned
Set searchC = sh.UsedRange.Find(strBlock)
If searchC Is Nothing Then MsgBox "No such a field in the worksheet...": Exit Function
lastRow = sh.Cells(Rows.Count, searchC.Column).End(xlUp).row
'The following part works well only if the blocks are separated by empty rows, as you said it is your sheet data case...
Set rng = sh.Range(searchC, sh.Cells(LastRow, searchC.Column)).SpecialCells(xlCellTypeConstants)
ws.Range("A1").Resize(rng.Areas(blkNo).Rows.Count, 4).Value = rng.Areas(blkNo).Resize(, 4).Value
End Function
The above function should be called like this:
Sub testRetBlock()
testReturnBlock "INT_EXT_DOOR", 2
End Sub
But in order to see that the correct range has been returned, you must adapt them in a way (in your test sheet), do differentiate. I mean the second one to contain "HELLO1" (at least on its first row), the following "HELLO2" and so on...
Try this routine if it does what you need. otherwise it should be a good start for adding whatever you need on top.
Option Explicit
Sub CopyBlock()
Dim wb As Excel.Workbook
Dim wsSource As Excel.Worksheet
Dim wsDest As Excel.Worksheet
Dim wsSelect As Excel.Worksheet
Dim lBlockNo As Long
Dim strCellID As String
Dim lBlock As Long
Dim lRow As Long
Dim lBlockRow As Long
Dim lBlockCol As Long
Dim searchRange As Excel.Range
Dim bRange As Excel.Range
Dim cRange As Excel.Range
Set wb = ActiveWorkbook
' set the worksheet objects
Set wsSource = wb.Sheets("Source")
Set wsDest = wb.Sheets("Dest")
Set wsSelect = wb.Sheets("Select") ' here you select which block you want to copy
' Identifier String
strCellID = "INT_EXT_DOOR"
' Which block to show. We assume that the number is in cell A1, but could be anywhere else
lBlockNo = wsSelect.Range("A1")
lRow = 1
' Find block with lBlockNo
For lBlock = 1 To lBlockNo
' Search the identifier string in current row
Do
lRow = lRow + 1
Set searchRange = wsSource.Rows(lRow)
Set bRange = searchRange.Find(strCellID, LookIn:=xlValues)
Loop While (bRange Is Nothing)
Next lBlock
lBlockRow = bRange.Row
lBlockCol = bRange.Column
' Search the first with empty cell
Do
lRow = lRow + 1
Loop While wsSource.Cells(lRow, lBlockCol) <> ""
' Copy the range found into the destination sheet
Range(Cells(lBlockRow, lBlockCol), Cells(lRow - 1, lBlockCol + 3)).Copy wsDest.Range("A1")
' Note the block copied
wsDest.Cells(1, 6) = "Block No:"
wsDest.Cells(1, 8) = lBlockNo
' Clean up (not absolutely necessary, but good practice)
Set searchRange = Nothing
Set bRange = Nothing
Set cRange = Nothing
Set wsSource = Nothing
Set wsDest = Nothing
Set wsSelect = Nothing
Set wb = Nothing
End Sub
Let me know if you need more help
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.
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)