I am stuck at the following problem:
I am going through a certain range trough each item and then trying to create a new worksheet each time there is a new name in the range. (The range has several rows with the same name)
I am getting the range with the following code:
Set r = Range("a6", Range("a6").End(xlDown))
For Each Item In r
If Item.text[i]==item.text[i-1] Then create worksheet
Next Item
I can't figure out how to program the for each
Can anyone give a good suggestion ?
First I think Item is a restricted name.
Second in vb == is not what other languages use.
Third offset(row,Column) will move up/down/left/right
Dim r as range, rng as range
Set r = Range("a6", Range("a6").End(xlDown))
For Each rng In r
If rng <> item.offset(-1) Then
dim ws as worksheet
set ws =worksheets.add
ws.name = rng
end If
Next rng
This?
Set r = Range("a6", Range("a6").End(xlDown))
For Each Item In r
If Item.text[i]==item.text[i-1] Then 'this line has errors, but I'll let you fix it
Set NewSheet = ThisWorkbook.Worksheets.Add
End If
Next Item
Sub aAddworksheet()
Dim rRange As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim lastrow As Long
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Set rRange = ws.Range("A1:A10")
i = 1
For Each Item In rRange
Debug.Print Item(i)
If i > 1 Then
If Item(i).Value = Item(i - 1).Value Then
Set NewSheet = wb.Worksheets.Add()
End If
End If
i = i + 1
Next Item
End Sub
Related
I have a problem in a small part of my code : I want it to select the cells starting from c which is a cell meeting a condition that I have defined earlier, to the end of the list. In this range, I want it to copy the first value that exceeds resultat (a value obtained before).
With Worksheets("Feuil1").Range("A2:A5181")
Set c = .Find(Worksheets("Feuil2").Range("A14").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Range(Range(c), Range(c).End(xlDown)).Select
If c Is Nothing Then
GoTo DoneFinding
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
Dim c As Range
Dim firstAddress As String
Dim resultat As Double
Dim Cel As Range
Dim firstValue As Integer
Dim s1 As String, s2 As String
s1 = Worksheets("Feuil2").Range(c)
s2 = Worksheets("Feuil1").Range(s1).End(xlDown)
Worksheets("Feuil1").Range(s1 & ":" & s2).Select
For Each Cel In Range(s1 & ":" & s2)
If Cel.Value >= resultat Then
firstValue = Cel.Value
firstAddress = Cel.Address
Exit For
End If
Next
Worksheets("Feuil1").firstValue.Copy
Range("C14").Worksheet("Feuil2").PasteSpecial
I get an error for the 2 first lines of the code.
Thanks a lot for your help.
This is my new code, because I realized something is missing.. The SearchRange does not start from row 2, but from the row where the value (a date) is equal to the last date of ws2. I get an error for my For each line. It says Object required.
Edit - New code, object error at rangyrange :
Private Sub CommandButton1_Click()
Dim rangyrange As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim foundRange As Range
Dim searchRange As Range
Dim lastRow As Long
Dim ws1Cell As Range
Dim firstAddress As String
Dim Cel As Range
Dim firstValue As Double
Dim A15Value As Date
Dim firsty As Long
Dim newRange As Range
Dim lastRow2 As Long
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Feuil1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Feuil2")
A15Value = CDate(ws2.Cells(15, 1).Value)
With ws1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastRow2 = .Cells(.Rows.Count, 2).End(xlUp).Row
Set foundRange = ws1.Range(.Cells(2, 1), .Cells(lastRow, 1))
Set searchRange = foundRange.Find(A15Value, LookIn:=xlValues)
Set rangyrange = ws1.Range(.Cells(searchRange.Row, 1), .Cells(lastRow, 1))
firsty = rangyrange.Rows(1).Row
Set newRange = ws1.Range(.Cells(firsty, 2), .Cells(lastRow2, 2))
End With
For Each ws1Cell In newRange
If ws1Cell.Value >= resultat Then
firstValue = ws1Cell.Value
firstAddress = ws1Cell.Address
Exit For
End If
Next
ws2.Cells(15, 3).Value = firstValue
End Sub
Dim c As Range
Worksheets("Feuil1").Range(Worksheets("Feuil1").Range(c), Worksheets("Feuil1").Range(c).End(xlDown))
You haven't set c to a range, so VBA doesn't understand what you're doing.
Also, I suggest defining a worksheet variable to increase the readability of your code like this:
Set ws = Excel.Application.Worksheets("Feuil1")
And your statement becomes much more legible:
ws.Range(ws.Range(c), ws.Range(c).End(xlDown))
This is not how you reference a range, also, I would suggest never using .Select.
Range(s1 & ":" & s2).Select
This is how you reference a range:
'this is my preferred method of referencing a range
Set someVariable = ws.Range(ws.Cells(row, column), ws.Cells(row, column))
Or...
'this is useful in some instances, but this basically selects a cell
Set someVariable = ws.Range("B2")
Or...
'this references the range A1 to B1
Set someVariable = ws.Range("A1:B1")
Also, as #BigBen pointed out, you cannot set a range like so:
Dim c As Range
s1 = Worksheets("Feuil2").Range(c)
The reasons being:
c hasn't been assigned.
You can't use a range as an input unless it's of the form ws.Range(ws.Cells(row, column), ws.Cells(row, column))
Per your update that includes the assignment for c:
I get an error for the 2 first lines of the code.
This is because you're assigning c before you're declaring c.
You should have all of your Dim statements preceding your actual code (unless you know what you're doing) like so:
Public Sub MySub()
Dim c As Range
Dim firstAddress As String
Dim resultat As Double
Dim Cel As Range
Dim firstValue As Integer
Dim s1 As String, s2 As String
`the rest of your code
End Sub
I would change your Do loop to the following:
With Worksheets("Feuil1").Range("A2:A5181")
Set c = .Find(Worksheets("Feuil2").Range("A14").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do While c.Address <> firstAddress
'I'm unsure of the goal here, so I'm ignoring it
Range(Range(c), Range(c).End(xlDown)).Select
If c Is Nothing Then
Exit Do
End If
Loop
End If
End With
Mainly because I hate GoTo statements and because the MS doc for Do loops states to use either Do While or Do Until instead of Loop While or Loop Until
s1 and s2 are strings, so you can't do this:
s1 = Worksheets("Feuil2").Range(c)
s2 = Worksheets("Feuil1").Range(s1).End(xlDown)
I'm assuming you want to get the column and row of c and iterate through that, but the problem is that you're working in 2 different worksheets, which you can't do. I'll assume it's an error and that you want to work on the "Fueil2" worksheet, so here goes:
Dim ws2 As Worksheet
Dim startCell As Range
Dim endCell As Range
Dim foundRange As Range
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Fueil2")
With ws2
Set startCell = .Cells(c.Row, c.Column)
Set endCell = .Cells(c.End(xlUp).Row, c.Column)
Set foundRange = .Range(.Cells(c.Row, c.Column), .Cells(c.End(xlUp).Row, c.Column))
For Each Cel In foundRange
'yada yada yada
End With
Post-lunch Edit:
It seems that this is a bit misleading because I tested this snippet and it works:
Public Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim foundRange As Range
Dim searchRange As Range
Dim workRange As Range
Dim foundColumn As Range
Dim ws1LastCell As Range
Dim ws1Range As Range
Dim iWantThis As Range
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Sheet2")
Set searchRange = ws1.Range("A1:F1")
Set foundRange = searchRange.Find(ws2.Range("C1").Value, LookIn:=xlValues)
With foundRange
'last cell in the ws1 column that's the same column as foundRange
Set ws1LastCell = ws1.Range(ws1.Cells(.Row, .Column), ws1.Cells(ws1.Rows.Count, .Column)).End(xlDown)
'the range you want
Set iWantThis = ws1.Range(foundRange, ws1LastCell)
'check to see if it got what i wanted on ws1
iWantThis.Select
End With
End Sub
New Edit:
Public Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim c14Value As Double
Dim searchRange As Range
Dim lastRow As Long
Dim ws1Cell As Range
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Sheet2")
'gets the date
A14Value = CDate(ws2.Cells(14, 1).Value)
With ws1
'gets the last row's number in column A on worksheet 1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'selects from A2 to the last row with data in it. this works only if
'there aren't any empty rows between your data, and that's what i'm assuming.
Set searchRange = .Range(.Cells(2, 1), .Cells(lastRow, 1))
End With
For Each ws1Cell In searchRange
If CDate(ws1Cell.Value) >= A14Value Then
'i didnt make a variable for firstValue
firstValue = ws1Cell.Value
'i didnt make a variable for firstAddress
firstAddress = ws1Cell.Address
Exit For
End If
Next
'puts firstValue into cell C14 on ws2
ws2.Cells(14, 3).Value = firstValue
End Sub
Until I see a definition for resultat, I'm assuming it's 100% correctly declared and assigned. hint: You should give us your declaration and assignment of resultat because I can't fully determine if how you defined resultat is an issue.
I have a noncontiguous range and I want whatever the user writes in each cell in the range to show up in a column in a table I made. In the first column of my table I'm having the program number each generated entry in the table when the user adds a value in one of the specified cells all the way up to 18. I renamed each cell in the range to be "Space_ (some number)". Even though I have written in three of the specified cells, my table only shows me the first value in the first specified cell.
Here is my code so far:
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Integer
Dim rng As Range
Set rng = ws.Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
ws.Range("A13:A31,B13:B31").ClearContents
For i = 1 To 18
If Not IsEmpty("rng") Then
ws.Range("A12").Offset(1).Value = i
End If
Exit For
Next i
If Not IsEmpty("rng") Then
ws.Range("B12").Offset(1).Value = rng.Value
End If
End Sub
This should address the various issues I mentioned in my comment:
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Long
Dim rng As Range, r As Range
With ws
Set rng = .Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
.Range("A13:B31").ClearContents
For Each r In rng.Areas
If Not IsEmpty(r) Then
.Range("A13").Offset(i).Value = i + 1
.Range("B13").Offset(i).Value = r.Value
i = i + 1
End If
Next r
End With
End Sub
A couple things here - Instead of trying to put all your named ranges into a Range, put them individually in an Array and cycle through them - If they're not blank, put the value into the cell.
Your .Offset is always going 1 below row 12, so that's why you're only seeing one row of data.
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Long, j As Long
Dim rngarray As Variant
rngarray = Array("Space_7", "Space_10", "Space_13", "Space_16", "Space_19", "Space_22", "Space_25", "Space_28", "Space_31", "Space_34", "Space_37", "Space_40", "Space_53", "Space_56", "Space_59", "Space_62", "Space_65", "Space_68")
j = 12
ws.Range("A13:B31").ClearContents
For i = 0 To UBound(rngarray)
If ws.Range(rngarray(i)).Value <> "" Then
ws.Range("A12").Offset(j - 11).Value = i + 1
ws.Range("B12").Offset(j - 11).Value = ws.Range(rngarray(i)).Value
j = j + 1
End If
Next i
End Sub
I'd go as follows:
Sub test2()
Dim i As Integer
Dim rng As Range, cell As Range
With ThisWorkbook.Sheets("Sheet1")
.Range("A13:A31,B13:B31").ClearContents
Set rng = .Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
For Each cell In rng.SpecialCells(xlCellTypeConstants).Areas
ws.Range("A12:B12").Offset(i).Value = Array(i + 1, cell(1, 1).Value)
i = i + 1
Next
End With
End Sub
I need to copy the same worksheet X times (x = sheet2 row A) into a new workbook.
For each copy I need to:
1.Change a drop down to display the next value
2.Do a Refresh (Workbook is connected to a database which pulls different information based on the value of the drop down and is not automatically refreshed)
3.Copy just the values (no formulas)
Rename the sheet to the value of the drop down.
Save all of the copied worksheets into 1 workbook
My code (below) which is called on a button press currently saves the sheet X times based on sheet2 rowA (as intended).
It is missing steps 1,2,4 and 5
The code I have at the moment (called on button click)
Dim x As Integer '~~>Loop counter
Dim WS As Worksheet
Dim LastCellA As Range, LastCellB As Range
Dim LastCellRowNumber As Long
Set WS = Worksheets("Sheet2") '~~>Sheet with names
With WS
Set LastCellA = .Cells(.Rows.Count, "A").End(xlUp) '~~>Column with names.
'~~>This needs to be changed to find the range as data may not start at A1
x = Application.WorksheetFunction.Max(LastCellA.Row)
End With
For numtimes = 1 To x
ActiveWorkbook.Sheets("Sheet1").Copy _
After:=ActiveWorkbook.Sheets(Worksheets.Count)
'~~>Copy values only
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Next
Still... I'm not sure of the point that you "Import" different values based on a drop down. That may be a different macro for loding the data. Then you need to call that macro instead of the .RefreshAll.
Sub test()
Dim uRow As Long, lRow As Long, i As Long
Dim wb As Workbook, ws As Object
With ThisWorkbook
Set ws = .Sheets("Sheet2")
With ws
uRow = .Cells(.Rows.Count, "A").End(xlUp).End(xlUp).Row
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set wb = Workbooks.Add
For i = uRow To lRow
.Sheets("Sheet1").Range("M1").Value = ws.Cells(i, 1).Value '<~~~ this should change the dropdown
Calculate
.RefreshAll
.Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
Next
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
For Each ws In wb.Sheets
ws.UsedRange.Value = ws.UsedRange.Value
Next
End With
End Sub
EDIT:
If you get trouble with the Sheet2 Column A List (cus it contains empty cells resulting of formulas) you may try a different approach:
Sub test()
Dim wb As Workbook, ws As Worksheet
Dim xVal As Variant
With ThisWorkbook
Set ws = .Sheets("Sheet2")
Set wb = Workbooks.Add
For Each xVal In Intersect(ws.Range("A:A"), ws.UsedRange).Value
If Len(xVal) Then
.Sheets("Sheet1").Range("M1").Value = xVal
Calculate
.RefreshAll
.Sheets("Sheet1").Copy , wb.Sheets(wb.Sheets.Count)
wb.Sheets(wb.Sheets.Count).Name = ws.Cells(i, 1).Value
wb.Sheets(wb.Sheets.Count).UsedRange.Value = wb.Sheets(wb.Sheets.Count).UsedRange.Value
End If
Next
Application.DisplayAlerts = False
wb.Sheets(1).Delete
Application.DisplayAlerts = True
End With
End Sub
Based on the code you provided, I believe this is what you are looking for.
It will loop through your list, copy sheet1 to the new workbook and name the sheet.
I am not sure what you want with looping through your dropdown list.
Sub Button1_Click()
Dim wb As Workbook, Bk As Workbook
Dim WS As Worksheet, sh As Worksheet
Dim LastCellA As Long, LastCellB As Range, c As Range
Dim LastCellRowNumber As Long
Dim x As Integer '~~>Loop counter
Set wb = ThisWorkbook
Set WS = wb.Worksheets("Sheet2") '~~>Sheet with names
Set sh = wb.Sheets("Sheet1")
With WS
LastCellA = .Cells(.Rows.Count, "A").End(xlUp).Row '~~>Column with names.
'~~>This needs to be changed to find the range as data may not start at A1
Set LastCellB = .Range("A1:A" & LastCellA).SpecialCells(xlCellTypeConstants, 23)
End With
Set Bk = Workbooks.Add
For Each c In LastCellB.Cells
sh.Range("M1") = c
sh.Copy After:=Bk.Sheets(Worksheets.Count)
With ActiveSheet
'~~>Copy values only
.UsedRange.Value = .UsedRange.Value
.Name = c
End With
Next c
End Sub
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.
I found a thread that applied directly to the code that I'm trying to build here Excel VBA: Loop through cells and copy values to another workbook.
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim CurCell_1 As Range, CurCell_2 As Range
Dim Ran As Range
Dim Group As Range, Mat As Range
Application.ScreenUpdating = True
Set ws1 = ActiveWorkbook.Sheets("Scrap")
Set ws2 = ActiveWorkbook.Sheets("FC Detail")
For Each Mat In ws1.Range("E:E")
Set CurCell_2 = ws2.Range("F8")
For Each Group In ws1.Range("E:E")
Set CurCell_1 = ws1.Cells(Group.Row, Mat.Column)
If Not IsEmpty(CurCell_2) Then
CurCell_2.Value = CurCell_1.Value
End If
Next
Next
End Sub
This code works with one exception, it loops continually.
I thought that If Not IsEmpty would be the descriptor to VBA that once it reaches the end of the list to cease the program.
Further to my comment, try this. This will be much faster
Sub Test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim CurCell_1 As Range, CurCell_2 As Range
Dim Group As Range, Mat As Range, Ran As Range
Dim lRow As Long
Set ws1 = ActiveWorkbook.Sheets("Scrap")
Set ws2 = ActiveWorkbook.Sheets("FC Detail")
With ws1
lRow = .Range("E" & .Rows.Count).End(xlUp).Row
Set Ran = .Range("E1:E" & lRow)
For Each Mat In Ran
Set CurCell_2 = ws2.Range("F8")
For Each Group In Ran
Set CurCell_1 = .Cells(Group.Row, Mat.Column)
If Not IsEmpty(CurCell_2) Then
CurCell_2.Value = CurCell_1.Value
End If
Next
Next
End With
End Sub