I'm new to VBA and am having issues with Range syntax and what are acceptable arguments.
the purpose of this code is as follows:
user inputs value into cell D5 on Sheet2
User activates code with button
searches "configs" sheet for value
copies corresponding range after locating value
pastes range back into Sheet2
the range I am attempting to copy paste is a block that starts with the selected cell (D5) on sheet "Configs", and continues until an empty cell is found.
Sub search()
Dim GCell As Range,
Dim box As Integer
Dim Avio As String
Dim Sheet2 As Worksheet, Configs As Worksheet
Dim rw1 As String, rw2 As String
Set Configs = ActiveWorkbook.Sheets("Configs")
Set Sheet2 = ActiveWorkbook.Sheets("Sheet2")
Avio = Range("D5").Value
Set GCell = Configs.Cells.Find(Avio)
box = 0
LoopX:
box = box + 1
If GCell.Offset(box, 0).Value = "" Then
rw1 = GCell.Offset(1, -1).Address
rw2 = GCell.Offset(box, 2).Address
Configs.Range("rw1:rw2").Copy <-- this syntax doesnt seem to work...
Sheet2.Range("Avio.Offset(1,0)").Paste <-- I know this is wrong, but I would like the range to be pasted just below the selected cell on Sheet2
Else: GoTo LoopX
End If
End Sub
Is this helping?
Sub search()
Dim GCell As Range
Dim box As Integer
Dim Sheet2 As Worksheet, Configs As Worksheet
Dim rw1 As String, rw2 As String
Set Configs = ActiveWorkbook.Sheets("Configs")
Set Sheet2 = ActiveWorkbook.Sheets("Sheet2")
Dim rngAvio As Range
Set rngAvio = Sheet2.Range("D5")
Set GCell = Configs.Cells.Find(rngAvio.Value)
box = 0
Do While (GCell.Offset(box, 0).Value <> "")
box = box + 1
rw1 = GCell.Offset(1, -1).Address
rw2 = GCell.Offset(box, 2).Address
Configs.Range(rw1 & ":" & rw2).Copy rngAvio.Offset(1, 0)
Loop
End Sub
Related
I want to write a macro to copy rows from one worksheet to another below cell that is colored black (manually) - if it is detected, otherwise just copy rows from first sheet to Sheet1 at the top. After many trials and errors I came up with that code:
Sub copytherows(clf As Long, lastcell As Long) 'clf - cell that marks the start, lastcell - ending cell
Dim st As Long, cnext As Range
Dim wshet As Worksheet
Dim wshetend As Worksheet
'st - start of looking up, cnext - range of lines, wshet - worksheet
Dim coprange As String
Dim cnextcoprow, cnextrow As Long
'variables for copying macro part
Dim rangehelper As Range
Dim TargetColor As Long
Dim cell As Range
Dim sht As Worksheet
Dim x As Long
Dim Aend As Long
Set wshet = Worksheets(1)
Set wshetend = Sheets("Sheet1")
wshetend.Cells.Delete
For st = 1 To wshet.Cells(Rows.Count, "B").End(xlUp).Row
If wshet.Cells(st, "B").Interior.Color = clf Then 'has the color of interest
cnextcoprow = st
Set cnext = wshet.Cells(st, "B").Offset(1, 0) 'next cell down
Do While cnext.Interior.Color <> lastcell
Set cnext = cnext.Offset(1, 0) 'next row
Loop
st = st + 1
End If
Next st
cnextrow = cnext.Row - 1
coprange = cnextcoprow & ":" & cnextrow
Aend = Cells(Rows.Count, "A").End(xlUp).Row
'set color is black
TargetColor = RGB(255, 255, 255)
wshetend.Activate
For x = 1 To Rows.Count
If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
x = x + 1
Set rangehelper = wshetend.Rows(x)
wshet.Range(coprange).Copy wshetend.Range(rangehelper).Offset(1)
Else
wshet.Range(coprange).Copy wshetend.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next x
End Sub
When Macro is ran it displays an error(Run-time error '1004' Method 'Range' of object '_Worksheet' failed on line :
wshet.Range(coprange).Copy wshetend.Range(rangehelper).Offset(1)
Sheet1 is for sure present in Workbook.
Edit as suggested by #FaneDuru:
1 - in this image is my curret state of worksheet that is wshet in my macro and for example if I select (by checkboxes) section1 and section3, section3 should be in the place of black cell in section1 (the order of sections doesn't really matter to me) inside destination sheet ( I know I'm not good in explaining things like that).
2 - this should be end result of this macro
It's quite confusing how you use the for loops.
In the first one you use it to check for the start -which is fine- but then you put a while loop in there which will end up in an endless loop once your st gets past your lastcell row, instead use
ElseIf wshet.Cells(st, "B").Interior.Color = lastcell Then
cnextrow = st
Exit For
End If
In the second for loop you copy the rows if you find the black cell but you don't exit the for loop, speaking of which, you delete all the cells in your wshetend so you'll always start at row 1. So either you don't want to delete all the cells in your wshetend or the for loop is unnecessary.
This is my testSub and it copies from the first sheet to Sheet2 after the cell with black background (black = 0) (commented out the delete cells)
Sub TestBlackCellCopy()
Dim st As Long, cnext As Range
Dim wshet As Worksheet
Dim wshetend As Worksheet
'st - start of looking up, cnext - range of lines, wshet - worksheet
Dim coprange As String
Dim cnextcoprow, cnextrow As Long
'variables for copying macro part
Dim rangehelper As Range
Dim TargetColor As Long
Dim cell As Range
Dim sht As Worksheet
Dim x As Long
Dim Aend As Long
Dim clf As Long, lastcell As Long
clf = 5296274
lastcell = 65535
cnextcoprow = 0
Set wshet = Worksheets(1)
Set wshetend = Sheets("Sheet1")
' wshetend.Cells.Delete
For st = 1 To wshet.Cells(Rows.Count, "B").End(xlUp).Row
Debug.Print (wshet.Cells(st, "B").Interior.Color)
If wshet.Cells(st, "B").Interior.Color = clf And cnextcoprow = 0 Then 'has the color of interest
cnextcoprow = st
ElseIf wshet.Cells(st, "B").Interior.Color = lastcell Then
cnextrow = st - 1
Exit For
End If
Next st
coprange = cnextcoprow & ":" & cnextrow
Aend = Cells(Rows.Count, "A").End(xlUp).Row 'unused variable?
'set color is black
TargetColor = 0
wshetend.Activate
For x = 1 To Rows.Count
Debug.Print (wshetend.Cells(x, "A").Interior.Color)
If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A" & x).Offset(1)
Exit For
' Else
' wshet.Range(coprange).Copy wshetend.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next x
End Sub
So you'll have to figure out what exactly you want, to delete the cells? Then it starts at row 1, then put a skip after a copy you place after the second for loop.
Something like this:
wshetend.Activate
Aend = Cells(Rows.Count, "A").End(xlUp).Row
For x = 1 To Rows.Count
Debug.Print (wshetend.Cells(x, "A").Interior.Color)
If wshetend.Cells(x, "A").Interior.Color = TargetColor Then
wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A" & x).Offset(1)
GoTo skipFor
End If
Next x
wshet.Rows(coprange).EntireRow.Copy wshetend.Range("A1")
skipFor:
Hope this helps.
Please, try the next way. It should work if you respected all what we set in the above discussion (check boxes in G:G, black cells in B:B for first sheet, and a black cell in any place of the second sheet:
Sub CopyRowsCheckBox_Black_limited()
Dim wshet As Worksheet, wshetend As Worksheet, blackCell As Range, redCell As Range, rngCopy As Range
Dim sh As Shape, chkB As MSForms.CheckBox, cellPaste As Range, pasteRow As Long
Set wshet = ActiveSheet 'use here the sheet where from you need copying
Set wshetend = wshet.Next 'use here the sheet where to copy
'settings to make Find function searching for Interior color:
With Application.FindFormat
.Clear: .Interior.Color = vbBlack
.Locked = True
End With
'find the black cell in the second sheet:
Set cellPaste = wshetend.cells.Find(What:=vbNullString, After:=wshetend.Range("A1"), SearchFormat:=True)
If Not cellPaste Is Nothing Then 'set the row where to copy first
pasteRow = cellPaste.Offset(1).row
Else
pasteRow = 1
End If
'iterate between all shapes, found the ones being checkBoxes and being on column G:G, set the rows range and copy it:
For Each sh In wshet.Shapes
If TypeName(sh.OLEFormat.Object.Object) = "CheckBox" And sh.TopLeftCell.Column = 7 Then
Set chkB = sh.OLEFormat.Object.Object 'set the checkBox ActiveX object
If chkB.Value = True Then 'if it is checked
Set blackCell = wshet.Range("B:B").Find(What:=vbNullString, After:=wshet.Range("B" & _
sh.TopLeftCell.row), SearchFormat:=True) 'find first black cell
Set rngCopy = wshet.Range(wshet.Range("B" & sh.TopLeftCell.row), blackCell).EntireRow 'set the rows to be copied
rngCopy.Copy wshetend.Range("A" & pasteRow): pasteRow = pasteRow + rngCopy.rows.count 'copy and update pasting row
End If
End If
Next sh
MsgBox "Ready..."
End Sub
The range to be copied is the one between the checked check box and the first black cell in B:B column.
Important Note: The top left corner of the check boxes must be inside of first series row!
Please, send some feedback after testing it.
I am trying to add values from a specific range(column) into a listbox. However, the range has blank cells and duplicates that I am trying to get rid of. The following code works (no error msg) and does populate the listbox, but it does not get rid of the duplicates.
Can someone help?
Private Sub UserForm_Initialize()
Dim rang, rang1 As Range
Dim lstrow As Long
Dim list(), ListUniq() As Variant
Dim iRw As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim x As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Paramed Verification Grid")
Set rang = ws.Range("E3").CurrentRegion
lstrow = rang.Rows.Count + 1
Set rang1 = Range("E3:E" & lstrow)
'list = ws.Range("E3:E" & lstrow).SpecialCells(xlCellTypeConstants)
'Resize Array prior to loading data
ReDim list(WorksheetFunction.CountA(rang1))
'Loop through each cell in Range and store value in Array
x = 0
For Each cell In rang1
If cell <> "" Then
list(x) = cell.Value
x = x + 1
End If
Next cell
ListUniq = WorksheetFunction.Unique(list)
ListUniq = WorksheetFunction.Sort(ListUniq)
ProviderListBx.list = ListUniq
End Sub
Col B on "Sheet2" contains 370 rows of data.
Starting with "Sheet2" Cell B1, I want to search for a matching value in Col B on "Sheet1" (it could be located anywhere in the first 300 rows of "Sheet1" Col B).
If a match is found, copy the entire row from "Sheet1" and paste to Row1 on "Sheet2". Then, move to "Sheet2" Cell B2 and repeat the search, this time pasting the entire row from "Sheet1" to Row2 on "Sheet2". Continue moving thru the entire column of data on "Sheet2", searching for each cell's value on "Sheet1". If a search doesn't return a match, then do not paste anything to that row on "Sheet2" and just proceed to search for the next cell on "Sheet2". (For example, if Sheet1 Col B doesn't contain a match for Sheet2 Cell B3, then nothing gets pasted in Sheet2 Row3.)
I have found the following example, which starts to help me, but it specifies the search value and doesn't loop thru the entire column of values like I am attempting to do.
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Sheet1")
Set Target = ActiveWorkbook.Worksheets("Sheet2")
J = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("E1:E1000") ' Do 1000 rows
If c = "yes" Then
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
End If
Next c
End Sub
This should do the trick, and do it fast:
Option Explicit
Sub CopyYes()
'You need Microsoft Scripting Runtime library under Tools-References for this
Dim arrPaste As Variant: arrPaste = Sheet2.UsedRange.Value
Dim arrCopy As Variant: arrCopy = Sheet1.UsedRange.Value
Dim MyMatches As New Dictionary: Set MyMatches = CreateDictionary(arrCopy)
Dim i As Long
For i = 1 To UBound(arrPaste)
If arrPaste(i, 2) = vbNullString Then Exit For
If MyMatches.Exists(arrPaste(i, 2)) Then PasteData arrPaste, arrCopy, i, MyMatches(arrPaste(i, 2))
Next i
Sheet2.UsedRange.Value = arrPaste
Erase arrCopy
Erase arrPaste
End Sub
Private Function CreateDictionary(arr As Variant) As Dictionary
Dim i As Long
Set CreateDictionary = New Dictionary
For i = 1 To 300
CreateDictionary.Add arr(i, 2), i
Next i
End Function
Private Sub PasteData(arrPaste As Variant, arrCopy As Variant, i As Long, MyMatch As Long)
Dim j As Long
For j = 1 To UBound(arrCopy, 2)
If arrCopy(MyMatch, j) = vbNullString Then Exit For
arrPaste(i, j) = arrCopy(MyMatch, j)
Next j
End Sub
Use Range.Find to search for your matching cell
Use a Union to create a collection of the rows that are found
Once your loop is finished, copy your range all at once if the Union is not empty
Sub Shelter_In_Place()
Dim Source As Worksheet: Set Source = ThisWorkbook.Sheets("Sheet1")
Dim Target As Worksheet: Set Target = ThisWorkbook.Sheets("Sheet2")
Dim Found As Range, lr As Long
Dim CopyMe As Range
lr = Target.Range("B" & Target.Rows.Count).End(xlUp).Row
For i = 1 To lr
Set Found = Source.Range("B:B").Find(Target.Range("B" & i), LookIn:=xlWhole)
If Not Found Is Nothing Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, Target.Range("B" & i))
Else
Set CopyMe = Target.Range("B" & i)
End If
End If
Set Fouund = Nothing
Next i
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy
Source.Range("A1").PasteSpecial xlPasteValues
End If
End Sub
Sub CheckBox7_Click()
Dim cBox As CheckBox
Dim LRow As Integer
Dim LRange As String
LName = Application.Caller
Set cBox = ActiveSheet.CheckBoxes(LName)
'Find row that checkbox resides in
LRow = cBox.TopLeftCell.Row
LRange = "B" & CStr(LRow)
'Change text in column b, if checkbox is checked
If cBox.Value > 0 Then
ActiveSheet.Range(LRange).Value = "3300-0401"
'Clear text in column b, if checkbox is unchecked
Else
ActiveSheet.Range(LRange).Value = Null
End If
End Sub
I need value 3300-0401 to be entered in the first available cell beginning at b15 through b40. Also, where would this date be entered in the string?
Thanks, Jean
You can use the following to write to the first blank cell in the range B15:B40:
Sub WriteToFirstAvailableCellInRange()
Dim wb As Workbook
Dim ws As Worksheet
Dim firstEmptyCell As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
If ws.Range("B15").Value = "" Then
Set firstEmptyCell = ws.Range("B15")
Else
If ws.Range("B16").Value = "" Then
Set firstEmptyCell = ws.Range("B16")
Else
Set firstEmptyCell = ws.Range("B15").End(xlDown).Offset(1)
End If
End If
If firstEmptyCell.Row < 41 Then
firstEmptyCell.Value = "3300-0401"
Else
MsgBox "There aren't any empty cells in range B15:B40."
End If
End Sub
I have written the following code to create worksheet with names same as the names in first column of Sheet1
I am getting a TypeError when trying to set the name on the new worksheet but don't know why. Can someone help?
Sub CreateWorkSheets()
'
' Macro5 Macro
'
'
Dim r As Range
Set r = Sheets("Sheet1").Columns(1)
For Each cell In r
Dim aa As String
Dim newSheet As Worksheet
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
strTemp = cell.Value
newSheet.Name = strTemp // Error Here
Next cell
End Sub
I tried the following code as well and that doesn't work either even though strValue is valid
Sub Test1()
Sheets("Sheet1").Select
Dim x As Integer
' Set numrows = number of rows of data.
NumRows = Range("A2", Range("A2").End(xlDown)).rows.Count
' Select cell a1.
Range("A2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
Dim newSheet As Worksheet
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
Sheets("Sheet1").Range("B1").Value = "A" + Trim(Str(x))
strValue = "A" + Trim(Str(x))
newSheet.Name = Str(Sheets("Sheet1").Range(strValue).Value)
Next
End Sub
Apparently because you set:
Set r = Sheets("Sheet1").Columns(1)
It set the cell object to column $A:$A instead of $A$1 like you would think. I put this in the immediate window when I ran into the "cell.value" line:
?cell.Address
$A:$A
You should avoid using an entire column to do what you're trying to do and I would highly recommend you add these keywords to the top of your module:
Option Explicit
This will check your code a little more thoroughly and help you avoid unwanted errors.
To fix this, you can get the exact range you need and I recommend you declare every variable so it stays a specific type.
Something like this:
Option Explicit
Sub CreateWorkSheets()
Dim r As Range
Dim sh As Worksheet
Dim tempSh As Worksheet
Dim cell As Range
Dim strTemp As String
Set sh = Sheets("Sheet1")
Set r = sh.Range(sh.Cells(1, 1), sh.Cells(sh.Rows.Count, 1).End(xlUp))
For Each cell In r
Set tempSh = Sheets.Add(After:=Sheets(Sheets.Count))
strTemp = cell.Value
tempSh.Name = strTemp '// no more error
Next cell
End Sub