VBA copy entire row of List - vba

I have the following code:
Sub test()
Dim r As Range, rng As Range
Set r = Range("a6", Range("a6").End(xlDown))
For Each rng In r
If rng <> rng.Offset(-1) Then 'if range is not
Dim ws As Worksheet
Set ws = Worksheets.Add
ws.Name = rng
Else
End If
Next rng
End Sub
This would go through the range in A6 to AXX and create a worksheets for different names. I somehow can't figure out however how to copy the content of every row into every worksheet created.
So I want all the Ticker changes being copied into the new created worksheet ticker changes.
I know there is some way with the following:
Range(Cells(rng, 1), Cells(rng, 10)).Copy
But I don't know how to paste those to different worksheet.
Can someone please advice or guide. Thanks
Also when I try to run this macro it sometimes says:
That name is already taken try a different one.
However there is no worksheet with that name.

You only need to reference/specify the sheet that you want to use.
Try this (I included an inputbox to correct the name of the sheet if it is already taken :
Sub test_Nant()
Dim r As Range, rng As Range, ws As Worksheet, aWs As Worksheet
Set aWs = ActiveSheet
Set ws = Worksheets.Add
On Error GoTo SheetRename
ws.Name = "Changes list"
GoTo KeepLooping
SheetRename:
ws.Name = InputBox("Choose another name for that sheet : ", , rng.Value)
Resume Next
KeepLooping:
With aWs
Set r = .Range(.Range("a6"), .Range("a6").End(xlDown))
For Each rng In r
If rng <> rng.Offset(-1) Then 'if range is not
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 10)).Copy Destination:=ws.Range("A1")
Else
End If
Next rng
End With
End Sub

Related

How to merge 3 cells with using an absolute cell reference in VBA

Trying to put together a VBA macro Im trying to reference Sheet1A8(CSWAH_) as an absolute cell reference and merge SeparateA7(Last Name) and SeperateB7(First Name) so they'll display in SeperateE7(ASA Naming) and be able to carry it all the way down from E7 to E100.
Is something like this even possible?
Try this.
Sub Demo()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to your data sheet
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data using Column A
Set rng = .Range("E7:E" & lastRow) 'set range in Column E
rng.Formula = "=$B$1&""_""&A7&"",""&B7" 'enter formula in range
rng.Value = rng.Value 'display values in range
End With
End Sub

How to paste data from one worksheet under changing data from another worksheet?

I've been extensively researching this question but none of my findings have helped me fix my code.
I'm trying to copy all the data from worksheet2 and paste directly under the data from worksheet1 (which changes every month). This is what I have so far but every time I try to run it, it says
Runtime Error 9 'Subscript out of range'.
Sub macro8()
Sheets("worksheet2").UsedRange.Copy Destination:=Sheets("worksheet1").End(xlUp).Offset(1, 0)
End Sub
Try:
Sub macro8()
Sheets("worksheet2").UsedRange.Copy Destination:=Sheets("worksheet1").UsedRange.End(xlDown).Offset(1, 0)
End Sub
Edit:
Then do it the right way. You can change the column letter "A" with the letter of your continuous Column.
Sub macro8()
Dim Rng1 As Range, Rng2 As Range, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("worksheet1")
Set ws2 = Worksheets("worksheet2")
Set Rng2 = ws2.UsedRange 'Copy range
Set Rng1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Offset(1, 0) 'Paste range
Rng2.Copy Destination:=Rng1 'Copy/Paste
End Sub

Dynamically copy a worksheet multiple times and rename using VBA in Excel

I am trying to dynamically generate a custom number of worksheets based on a template that we use regularly in excel using VBA.
I have created an "Overview" page where we can input a range which will be used to name the new worksheets but then would like to use a hidden "Master" worksheet to generate the content of these new worksheets.
My code below currently generates the correct number of pages based on the range AND copies our master template page but does not combine the two and leaves them in separate pages.
Sub test()
Dim MyNames As Range, MyNewSheet As Range
Set masterSheet = ThisWorkbook.Worksheets("Master")
Set MyNames = Range("A1:A6").CurrentRegion ' load range into variable
For Each MyNewSheet In MyNames.Cells ' loop through cell range
masterSheet.Copy ThisWorkbook.Sheets(Sheets.Count) 'copy master template sheet
Sheets.Add.Name = MyNewSheet.Value
Next MyNewSheet
MyNames.Worksheet.Select ' move selection to original sheet
End Sub
As you can see, the code generates both the named (blank) worksheets AND copies my master worksheet which defaults to naming as "Master()".
So we just need to replace this line:
Sheets.Add.Name = MyNewSheet.Value
with this line:
ActiveSheet.Name = MyNewSheet.Value
Loop through the list and copy the sheet if the sheet does not already exist.
Sub CopyMaster()
Dim ws As Worksheet, sh As Worksheet
Dim Rws As Long, rng As Range, c As Range
Set sh = Sheets("Overview")
Set ws = Sheets("Master")
With sh
Rws = .Cells(Rows.Count, "A").End(xlUp).Row
Set rng = .Range(.Cells(1, 1), .Cells(Rws, 1))
End With
For Each c In rng.Cells
If WorksheetExists(c.Value) Then
MsgBox "Sheet " & c & " exists"
Else:
ws.Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = c.Value
End If
Next c
End Sub
Function WorksheetExists(WSName As String) As Boolean
On Error Resume Next
WorksheetExists = Worksheets(WSName).Name = WSName
On Error GoTo 0
End Function

How to iterate through rows in sheet1 given cell value in sheet2 and replace row in sheet1 with row in sheet 2?

I have to find and replace rows in sheet 1 given matching cell value in the same column in sheet2. The column number is 4.
HELPPP!!!
This is what I have right now and I get an error on next x.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets(Sheet1)
Set ws2 = Sheets(sheet2)
With wb
For i = 1 To ws2.Cells(Rows.Count, 4).End(xlUp).Row
Dim lookupvalue As String
lookupvalue = ws2.Cells(i, 4).Value
For x = 1 To ws1.Cells(Rows.Count, 4).End(xlUp).Row
Dim rng As range
For Each rng In range("D:D")
If InStr(1, rng.Value, "lookupvalue") > 0 Then
rng.Delete
End If
Next x
exitloop:
Next i
End With
End Sub
As A.S.H. said, the code needs a little improvement:
1) The two inner loops need to be combined.
2) The new inner loop should go from the bottom up, due to the fact that you are deleting the cell, This is probably why you have the second inner loop but that just adds time to the sub.
3) you are currently only deleting the one cell at a time, any data around it will remain. This may be what you want and so I left it, but if you meant to delete the entire row then uncomment the line that does that.
4) when testing with the instr function the variable should not be in quotes, with the variable in quotes it will look for that specific word "lookupvalues" and not the value assigned to that variable.
5) The with block that was being used did nothing. when using the with block the line that use it need to start with a '.' for example: on your code the with was with the workbook so every time a worksheet is used it should start with a "." like .ws1... and so forth. But by declaring the sheets using the workbook, this is no longer needed.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim lookupvalue As String
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("sheet2")
For i = 1 To ws2.Cells(Rows.Count, 4).End(xlUp).Row
lookupvalue = ws2.Cells(i, 4).Value
For x = ws.Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
Set rng = ws.Cells(x, 4)
If InStr(1, rng.Value, lookupvalue) > 0 Then
rng.Delete 'this only deletes the cell
'You may want this instead
'rng.entirerow.delete
End If
Next x
Next i
End Sub
I would like to propose an alternative way to handle this using a For Each Loop and the Find Method of the Range object.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lookup_rng As Range
Dim lookupvalue As String
Dim search_rng As Range
Dim rng As Range
Dim match_rng As Range
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Set lookup_rng = Application.Intersect(ws2.Range("D:D"), ws.UsedRange)
Set search_rng = Application.Intersect(ws.Range("D:D"), ws2.UsedRange)
For Each rng In lookup_rng.Cells
lookupvalue = rng.Value
With search_rng
Set match_rng = .Find(lookupvalue, LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlPrevious)
Do Until NoMoreMatches(match_rng)
match_rng.Delete 'Or match_rng.EntireRow.Delete if you want to delete the entire row.
Set match_rng = .FindPrevious
Loop
End With
Next
End Sub
Private Function NoMoreMatches(MatchRng As Range) As Boolean
NoMoreMatches = MatchRng Is Nothing
End Function
This approach is a little bit more wasteful then that of Scott Craner since the Find method always starts from the end of the range. However, I think it has the advantage that it is easier to read, i.e. that the code more directly shows what it is supposed to do.
Moreover, using this version you could extract the loops into a separate Sub you can use for arbitrary lookup and search ranges.

Excel VBA to search worksheet names and copy a range into active sheet

Can anyone please help me with this VBA code? I cannot find out how to search and select worksheets without knowing their names.
I would like to:
1) In my active worksheet, search cell values in range("H6:AW6"), and;
2) If a cell value matches another worksheet name, copy range("C7:C177") from that worksheet and paste it below that cell.
For example, if the cell value H6 of the active worksheet is "Salary" and we have a worksheet named "Salary", I would like a VBA to copy range("C7:C177") of worksheet "Salary" and paste into range("H7:H177") of the active worksheet.
This should work for you,
Sub Button1_Click()
Dim ws As Worksheet, sh As Worksheet
Dim Rng As Range, c As Range
Set ws = Sheets("Sheet1")
Set Rng = ws.Range("H6:AW6")
For Each sh In Sheets
For Each c In Rng.Cells
If sh.Name = c Then
sh.Range("C7:C177").Copy Destination:=ws.Cells(7, c.Column)
End If
Next c
Next sh
End Sub
Sub test()
Dim tmpCell As Range
For Each tmpCell In ActiveSheet.Range("H6:AW6")
On Error Resume Next
tmpCell.Offset(1).Resize(171).Value = _
ActiveWorkbook.Worksheets(tmpCell.Value).Range("C7:C177").Value
On Error GoTo 0
Next tmpCell
End Sub