Private Sub CommandButton1_Click()
Dim cel As Range, lRow As Long
'next line determines the last row in column 1 (A), of the first Worksheet
lRow = Worksheets("Delta").UsedRange.Columns(5).Rows.Count
'iterate over every cell in the UsedRange
For Each cel In Worksheets("Delta").Range("E10:E" & lRow)
'cel represents the current cell
'being processed in this iteration of the loop
'Len() determines number of characters in the cell
If Len(cel.Value2) > 0 Then
'if cel is not empty, copy the value to the cell range (D1,D2,D3...) mentioned
Sheets("Traceability").Select
Traceability.Range("D3:D100").Select = cel.Value2 '--->Object not defined
End If
Next 'move on the next (lower) cell in column 1
End Sub
For copying a range of data I am facing an error of object not defined. Is my method to copy cell values correct ?
This is what I came up to finally
Private Sub CommandButton1_Click()
Dim cel As Range, lRow As Long
Dim i As Integer
lRow = Worksheets("Delta").UsedRange.Columns(5).Rows.Count
rw = 3
'iterate over every cell in the UsedRange
For Each cel In Worksheets("Delta").Range("E10:E" & lRow)
If Len(cel.Value2) > 0 Then
'if cel is not empty, copy the value to the cell
Sheets("Traceability").Range("D" & rw).Value = cel.Value2
rw = rw + 1
End If
Next
End Sub
try:
Remove:
Sheets("Traceability").Select
Change:
Traceability.Range("D3:D100").Select = cel.Value2
to
Sheets("Traceability").Range("D3:D100") = cel.Value2
Its been a while since i had to do this, but if i remember right, selecting the worksheet does not assign it to a variable.
You've selected Traceability worksheet, then you try to do things on "Traceability" without telling it what "Traceability" is.
If that makes sense.
Related
i am stuck with my procject again... I tried with formulas but i can t make it work or i can t make it right, and i couldn t find similar topic any where, here is the problem. As u can see in screenshot in this link https://ibb.co/FJRBxcM i have 2 worksheets, Sheet1 with some value generator, and Sheet"RadniNalog" where i copy&paste manualy certan values from Sheet1. My goal is to make it work automatically, when i paste data from another Workbook, as shown in screenshot example, i polulate range "A10:C27", range width is constant, always 3 column, but rows can change so number is X. Now i need values from "A10:A27" to copy to next empty column from left to right in Sheet"RadniNalog" from cells in 2nd row. Next i also need to copy Value from cell =F$13$ into the first row in sheet "RadniNalog" (on screenshot example its cell "E1" and that value from F13 needs to act like a Header for values belove it. If Value from header is the same as value in cell "F13" i need to continue adding values under existing ones, and if not move to the next available column. In screenshot example, if cell "D1" from sheet "RandiNalog" is same as cell "F13" in Sheet1, then values from range "A10:A27" should be added under last value in ColumnD. I need some VBA code if possible to make it work as wanted. Thanks in advance
Copy this code to Sheet1 module
This code runs the macro copyValuesToWs when you put the code in F13
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F13:G13")) Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Call copyValuesToWs
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Create a new module and insert this code
Option Explicit
Function FindLastRow(ByVal Col As Byte, ws As Worksheet) As Long
FindLastRow = ws.Cells(Rows.Count, Col).End(xlUp).Row
End Function
Function FindLastColumn(ByVal rw As Byte, ws As Worksheet) As Long
FindLastColumn = ws.Cells(rw, Columns.Count).End(xlToLeft).Column
End Function
Sub copyValuesToWs()
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Radni nalog")
Dim lCol As Long
Dim lRow As Long
Dim srcRng As Range
Dim dstRng As Range
Dim hdRng As Range
' Next row after ID
Dim idRng As Range: Set idRng = ws1.Range("A10")
' find last row value in column A
lRow = FindLastRow(1, ws1)
' range to be copied
Set srcRng = ws1.Range(ws1.Cells(idRng.Row, 1), ws1.Cells(lRow, 1))
' find last used column in sheet2
lCol = FindLastColumn(1, ws2)
' header range
Set hdRng = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, lCol))
' check if value exists in header
On Error Resume Next
Dim sValue As Double: sValue = Application.WorksheetFunction.Match(ws1.Range("F13").Value, hdRng, 0)
If Err.Number = 0 Then ' value exists
' find last row
Set dstRng = ws2.Cells(FindLastRow(sValue, ws2) + 1, sValue)
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
Else
' set destination range
Set dstRng = ws2.Cells(2, lCol + 1)
' set header value
ws1.Range("F13:G13").Copy
ws2.Cells(1, lCol + 1).PasteSpecial xlPasteValues
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
End If
On Error GoTo 0
Application.CutCopyMode = False
End Sub
I am trying to write some VBA in excel that will clear all cells starting from the next empty cell in Column A (data starts from A2). For example, if A5 is blank then I want A5:P300 to all be cleared (as in all Formula and Data gone). And so on... so if A20 is blank then it deletes everything from A20:P300..
How would I go about writing this? I also need it to refer to the active workbook but a specific worksheet called ("Develop").
Thanks for any help provided.
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("R&DCosts(2)")
Set rng = x.Range("A2:A340").Cells(Rows.Count, 1).End(xlUp)
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
Try this code, please:
Sub clearRange_Bis()
Dim sh As Worksheet, firstEmpt As Long
Set sh = ThisWorkbook.Worksheets("R&DCosts(2)")
firstEmpt = sh.Range("A1").End(xlDown).Row + 1
If firstEmpt > 1000000 Then
sh.Range("A2:P300").Clear
Else
sh.Range("A" & firstEmpt & ":P300").Clear
End If
End Sub
A more simple solution
Option Explicit
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("RDCosts(2)") ' you cannot use "&"
Set rng = x.Range("A2:A340", Cells(Rows.Count, 1).End(xlUp))
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
Goal: Have the column header of any text in red be represented in column F of the same row as the text.
Problem: Code currently references active row, and for some reason copies F2 (which is written in red). I know the code currently would be attempting to copy/paste over a cell a few times, and I'll work that out later.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, ActiveCell.Column).Copy
Range("F" & (ActiveCell.row)).Select
ActiveSheet.Paste
End If
Next cell
Next row
End Sub
Not sure if I follow your logic. Your problem is that you reference active cell but you are not defining it or changing it other than through the pasting. I think you mean to reference cell (?)
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, cell.Column).Copy Range("F" & cell.row)
End If
Next cell
Next row
End Sub
You are never changing the active cell, so the copy command is always called on row 2 of the active cell, which much be in the F column. I changed the code below to fix the issue.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet ' this should be improved to point at the correct worksheet by name
Set rng = ws.Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
cell.Copy
ws.Range("F" & (cell.row)).PasteSpecial
End If
Next cell
Next row
End Sub
The code below searches for duplicates in different sheets of my work book. The issue is that it takes a little while for it to be done. How can I add a progress indicator in the status bar at the bottom?
Thank you & Kind regards.
Sub dup()
Dim cell As Range
Dim cella As Range
Dim rng As Range
Dim srng As Range
Dim rng2 As Range
Dim SheetName As Variant
Application.ScreenUpdating = False
Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Set srng = Sheets("Screener").Range("A7:A2000")
Set rng = Sheets("Rejected").Range("A7:A2000")
Set rng2 = Sheets("Full Data").Range("A7:A2000")
For Each cell In rng
For Each cella In srng
If cella = cell Then
cella.Interior.ColorIndex = 4
cella.Offset(, 1) = "Rejected"
End If
Next cella
Next cell
For Each cell In rng2
For Each cella In srng
If cella = cell Then
cella.Interior.ColorIndex = 5.5
cella.Offset(, 1) = "Reported"
End If
Next cella
Next cell
Application.ScreenUpdating = True
End Sub
One thing you can do is speed up your code, there's a few things I'd change about it in its current state,
It's really slow to access range objects and their value, you should instead load the ranges into a variant array and cycle through the arrays
If you find a duplicate, you still go through and check every other range in both arrays which wastes time, you should skip to the next range once you've found a duplicate
With that in mind I've rewritten your code like this, it's completely equivalent and runs in less than a second on my machine:
Sub dup()
Dim i As Integer, j As Integer
Dim RejectVals As Variant
Dim ScreenVals As Variant
Dim FullDataVals As Variant
Dim SheetName As Variant
Dim output() As String
'Push column on 'Screener' sheet to the right to make space for new output
Worksheets("Screener").Range("A7:A15").Interior.ColorIndex = xlNone
Worksheets("Screener").Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Pull the values from your 3 ranges into arrays to avoid costly cycling through ranges
ScreenVals = Application.Transpose(Sheets("Screener").Range("A7:A2000").Value)
RejectVals = Application.Transpose(Sheets("Rejected").Range("A7:A2000").Value)
FullDataVals = Application.Transpose(Sheets("Full Data").Range("A7:A2000").Value)
'Resize output column to be same size as column we're screening because
'we're going to place it in the column adjacent
ReDim output(LBound(ScreenVals) To UBound(ScreenVals))
'Cycle through each value in the array we're screening
For i = LBound(ScreenVals) To UBound(ScreenVals)
'Skip without checking if the cell is blank
If ScreenVals(i) = vbNullString Then GoTo rejected
'Cycle through each value in the 'FullData' array
For j = LBound(FullDataVals) To UBound(FullDataVals)
'If it's a duplicate then
If ScreenVals(i) = FullDataVals(j) Then
'Set the relevant value in the output array to 'Reported'
output(i) = "Reported"
'Colour the cell on the 'screener' page
Worksheets("Screener").Cells(i + 6, 1).Interior.ColorIndex = 5.5
'Skip checking more values
GoTo rejected
End If
Next j
'Next cycle through all the 'Rejected' values
For j = LBound(RejectVals) To UBound(RejectVals)
'If it's a duplicate then
If ScreenVals(i) = RejectVals(j) Then
'Set the relevant value in the output array to 'Rejected'
output(i) = "Rejected"
'Colour the cell
Worksheets("Screener").Cells(i + 6, 1).Interior.ColorIndex = 4
'Skip checking any more values
GoTo rejected
End If
Next j
rejected:
Next i
'Pop the output array in the column next to the screened range
Worksheets("Screener").Range("B7:B2000") = Application.Transpose(output)
End Sub
I check for duplicates in the 'Full Data' sheet first which means if there is a duplicate in both tables then it will default to 'Reported' and a yellow cell, if you'd like the opposite you can swap the order of the loops.
Let me know if there's anything you don't understand
Data is transferred from a web-form to Excel. Not every cell receives inputs. There are many cells, it is time consuming to scan each cell looking for text.
How do I get the text automatically copied from sheet1 to sheet2. But I don't want the cells displayed in the same layout as the original sheet. I would like them to be grouped together, eliminating all of the empty cells in between. I would also like to grab the title from the row that contains the text.
I found this macro:
Sub CopyC()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("C1:C10")
For Each cel In SrchRng
If cel.Value <> "" Then
cel.Offset(2, 1).Value = cel.Value
End If
Next cel
It grabs only cells that contain text, but it displays it in the exact same layout that it found it in. Any help would be appreciated and save me a lot of scan time in the future, thanks in advance :)
I guess this is what you are looking for:
Sub CopyNonBlankCells()
Dim cel As Range, myRange As Range, CopyRange As Range
Set myRange = Sheet1.Range("C1:C20") '---> give your range here
For Each cel In myRange
If Not IsEmpty(cel) Then
If CopyRange Is Nothing Then
Set CopyRange = cel
Else
Set CopyRange = Union(CopyRange, cel)
End If
End If
Next cel
CopyRange.Copy Sheet2.Range("C1") '---> enter desired range to paste copied range without blank cells
End Sub
Above code will copy range C1:C20 in Sheet1 to C1 in Sheet2
Got this from here.
EDIT: Following answer is based on your comment
________________________________________________________________________________
If you'll write something like below
Set myRange = Sheet1.Range("G:G")
Set myRange = Sheet2.Range("G:G")
myRange will be first set to Sheet1.Range("G:G") and then to Sheet2.Range("G:G") that means current range that myRange will have is Sheet2.Range("G:G").
If you want to use multiple ranges you can go for UNION function but there's a limitation that using UNION, you can combine different ranges but of only one sheet. And your requirement is to combine ranges from different sheets. To accomplish that I am adding a new worksheet and adding your G:G ranges from all the sheets to it. Then after using newly added sheet I am deleting it.
Following code will give you the desired output in the sheet named Result.
Sub CopyNonBlankCells()
Dim cel As Range, myRange As Range, CopyRange As Range
Dim wsCount As Integer, i As Integer
Dim lastRow As Long, lastRowTemp As Long
Dim tempSheet As Worksheet
wsCount = Worksheets.Count '--->wsCount will give the number of Sheets in your workbook
Set tempSheet = Worksheets.Add '--->new sheet added
tempSheet.Move After:=Worksheets(wsCount + 1)
For i = 1 To wsCount
If Sheets(i).Name <> "Result" Then '---> not considering sheet "Result" for taking data
lastRow = Sheets(i).Cells(Rows.Count, "G").End(xlUp).Row '--->will give last row in sheet
lastRowTemp = tempSheet.Cells(Rows.Count, "G").End(xlUp).Row '--->will give last row in newly added sheet
Sheets(i).Range("G1:G" & lastRow).Copy _
tempSheet.Range("G" & lastRowTemp + 1).End(xlUp)(2)
End If
Next i
lastRowTemp = tempSheet.Cells(Rows.Count, "G").End(xlUp).Row
Set myRange = tempSheet.Range("G1:G" & lastRowTemp) '--->setting range for removing blanks cells
For Each cel In myRange
If Not IsEmpty(cel) Then
If CopyRange Is Nothing Then
Set CopyRange = cel
Else
Set CopyRange = Union(CopyRange, cel)
End If
End If
Next cel
CopyRange.Copy Sheets("Result").Range("G1") '---> enter desired range to paste copied range without blank cells
Application.DisplayAlerts = False
tempSheet.Delete '--->deleting added sheet
Application.DisplayAlerts = True
End Sub
You can use arrays!
Instead of copying information from one cell to another, you can store all your information in an array first, then print the array on another sheet. You can tell the array to avoid empty cells. Typically, using arrays is the best way to store information. (Often the fastest way to work with info)
If you are only looking at one column, you could use a one-dimensional array. If you are looking at multiple columns, and want to print the information into the corresponding column (but different cells) in another page then you could a multi-dimensional array to store column number/anything else you wanted.
From your code, it could look like this:
Sub CopyC()
Dim SrchRng As Range, cel As Range
'Declare your 1-d array (I don't know what you are storing)
Dim myarray() as variant
Dim n as integer
Dim i as integer
Set SrchRng = Range("C1:C10")
'define the number of elements in the array - 1 for now, increase it as we go
n = 0
Redim myarray(0 to n)
For Each cel In SrchRng
If cel.Value <> "" Then
'redim preserve stores the previous values in the array as you redimension it
Redim Preserve myarray(0 to n)
myarray(n) = cel.Value
'increase n by 1 so next time the array will be 1 larger
n = n + 1
End If
Next cel
'information is now stored, print it out in a loop
'this will print it out in sheet 2 providing it is called "Sheet2"
For i = 0 to ubound(myarray)
Sheets("Sheet2").cells(i,1).value = myarray(i)
Next i