I have 8000 rows of data in column A.
I am trying to write code that would scan the rows and each time there's a cell formatted as bold, to determine a range that includes that cell and all cells in the subsequent rows until the next bold cell. This range should be copied to column B, tranposed.
Here's the code that I have so far:
Sub Sorting()
Application.ScreenUpdating = False
last_row = ActiveSheet.Range("A" & Cells.Rows.Count).End(xlUp).Row
y = 1
For i = 1 To LastRow
If Range("A" & i).Font.Bold = True Then
Range("A" & i).Copy Range("A" & i + 9)
Range("B" & y).PasteSpecial Transpose:=True
y = y + 1
x = i
Else
Range("A" & x).Copy Range("B" & i)
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub doIt()
Dim a1 As Range: Set a1 = Range("A1")
Dim a2 As Range: Set a2 = a1.Offset(1)
Dim b As Range: Set b = Range("B1")
Do Until Intersect(a2, ActiveSheet.UsedRange) Is Nothing
If a2.Font.Bold Then
b.Resize(, a2.row - a1.row) = Application.Transpose(Range(a1, a2.Offset(-1)))
Set a1 = a2: Set a2 = a1.Offset(1): Set b = b.Offset(1)
Else
Set a2 = a2.Offset(1)
End If
Loop
b.Resize(, a2.row - a1.row) = Application.Transpose(Range(a1, a2.Offset(-1)))
End Sub
Related
I am trying to write a VBA code for an Excel macro so that I can manually trigger the macro to do the following:
In the event that any two rows have:
Same value in column A
Same value in Column B
"apple" in Column C
Same value in Column D
Then I would like all of those rows to be deleted except the row with the highest value in column E.
As an example, if:
cell A1 = cell A2
cell B1 = cell B2
cell C1 and Cell C2 = "apple"
cell D1 = cell D2
Cell E1 = 5 and Cell E2 = 10
Then Row 1 gets deleted and Row 2 remains.
The overall goal is to delete similar rows.
Per a user's suggestions, this process can be aided/simplified by sorting range by c="apple",a,b,d so that rows can be analyzed consecutively.
Example of Code Outcome
I put together the following code, but I am unfamiliar with the delete row aspect and how to incorporate the highest value, but this was my best shot. The If and elseif statements are questionable.
Sub Macro()
Dim a As Range
Dim b As Range
Dim c As Range
Dim d As Range
Dim e As Range
For Each a In Range("A1:A9999")
For Each b In Range("B1:B9999")
For Each c In Range("C1:C9999")
For Each d In Range("D1:D9999")
For Each e In Range("E1:E9999")
If a.Offset(-1, 0) = a And b.Offset(-1, 0) And c.Offset(-1, 0) = c And d.Offset(-1, 0) = d And e.Offset(-1, 0) < e Then Range(a).EntireRow.Delete
ElseIf a.Offset(-1, 0) = a And b.Offset(-1, 0) And c.Offset(-1, 0) = c And d.Offset(-1, 0) = d And e.Offset(-1, 0) > e Then Range(a.Offset(-1, 0)).EntireRow.Delete
Exit For
Next a
Next b
Next c
Next d
Next e
End Sub
I hope it works.
Option Explicit
Sub RunMacro()
Dim i As Long, LastRow As Long, j As Long
Dim cellA, cellB, cellC, cellD, cellE
Dim Rng As Range
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
cellA = Range("A" & i).Value
cellB = Range("B" & i).Value
cellC = Range("C" & i).Value
cellD = Range("D" & i).Value
cellE = Range("E" & i).Value
For j = LastRow To 2 Step -1
If Range("A" & j).Value = cellA And Range("B" & j).Value = cellB Then
If Range("C" & j).Value = cellC And Range("D" & j).Value = cellD Then
If cellE > Range("E" & j).Value Then
Range("E" & j).EntireRow.Delete
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
End If
End If
End If
Next j
Next i
LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
With ActiveSheet
Set Rng = Range("A1", Range("E1").End(xlDown))
Rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
End With
End Sub
I'm trying to write a macro to autofill a range dynamically as you can see in the photo :
I've tried this code and it return an error :
Sub Auto()
Dim selection1 As Range
Dim selection2 As Range
h = 1
g = 1
This two loops I used to detect the the first empty cell in column AZ to refer to its range later
Do Until Cells(h + 1, 52).Value = ""
h = h + 1
Loop
Do Until Cells(g + 1, 1).Value = ""
g = g + 1
Loop
Set selection1 = Range("AZ" & h & ":" & "BD" & h)
Set selection2 = ActiveSheet.Range("AZ" & g & ":" & "BD" & g)
This where I tested the above idea and it worked fine and the range selected as it should as shown in the photo
Range("AZ" & h & ":" & "BD" & h).Select
'Autofill
This where I got the error:
'Selection.AutoFill Destination:=Range("AZ" & g & ":" & "BD" & g), Type:=xlFillDefault
End Sub
Any Ideas?
This will autofill the data down.
The method for finding the last row is the same as going to the last row and pressing Ctrl+Up.
Sub Test()
Dim LastRow1 As Long, LastRow2 As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow1 = .Cells(.Rows.Count, "AY").End(xlUp).Row 'Find last row in column AY.
LastRow2 = .Cells(.Rows.Count, "AZ").End(xlUp).Row 'Find last row in column AZ.
.Range(.Cells(LastRow2, "AZ"), .Cells(LastRow2, "BD")).AutoFill _
Destination:=.Range(.Cells(LastRow2, "AZ"), .Cells(LastRow1, "BD"))
End With
End Sub
Worksheet picture
I want to add the text LAURA to column E in front of the existing text in the column when it gets copied to the targeted worksheet:
Private Sub CommandButton1_Click()
Dim wsSource, wsTarget As Worksheet
Dim i, iLastSource, iRowTarget, count As Long
Dim cell As Range
Set wsSource = Worksheets("Stig Jan")
iLastSource = wsSource.Cells(Rows.count, 1).End(xlUp).Row
Set wsTarget = Worksheets("Laura Jan")
count = 0
With wsSource
iRowTarget = wsTarget.Cells(Rows.count, 1).End(xlUp).Row + 1
For i = 36 To iLastSource
Set cell = .Cells(i, 4)
If cell.Font.Bold = False Then
If cell.Value = "Fælles" Or cell.Value = "Lagt Ud" Then
wsTarget.Range("A" & iRowTarget & ":H" & iRowTarget).Value = .Range("A" & i & ":H" & i).Value
wsTarget.Range("D" & iRowTarget).ClearContents
**wsTarget.Range("E" & iRowTarget).Value = "LAURA. " & cell.Value**
iRowTarget = iRowTarget + 1
count = count + 1
End If
End If
If cell.Value = "Fælles" Or cell.Value = "Lagt Ud" Then
wsSource.Rows(i).Columns("D").Font.Bold = True
End If
Next
As of now it copies the value in column D instead. So LAURA + Column D
I hope I will be able to explain my Macro requirement well.
Basically it has 5 columns. Col A - Resource Name, Col B - Role, Col C - Month Start Date, Col D - Month End Date, Col E - Percentage.
Please see the attached Image for a Clear Picture.
![enter image description here][3]
Code: It just prints the First Slot ( First Month - Col E F G )
Attached!
Dim A1, A2, A3, A4, A5 As Range
Dim i As Integer
Range("A5").Select
i = ActiveCell.Row
j = ActiveCell.Column
While (ActiveCell.Value <> "Null")
Set A1 = Nothing
Set A2 = Nothing
Set A3 = Nothing
Set A4 = Nothing
Set A5 = Nothing
If (Range("P" & i).Value) > 0 Then
Set A1 = Range("C" & i) ' Role
Set A2 = Range("A" & i) ' Resource Name
Set A3 = UpdateStartDate(i) ' Start Date
Set A4 = UpdateEndDate(i) ' End Date
Set A5 = UpdatePercent(i) ' Percentage
Call TransferData(A1, A2, A3, A4, A5)
Else
End If
i = i + 1
Range("A" & i).Select
Wend
End Sub
Sub TransferData(A1, A2, A3, A4, A5 As Range)
Dim i As Integer
i = ActiveCell.Row
Range("R" & i).Value = A1 'Role
Range("S" & i).Value = A2 'Resource Name
Range("T" & i).Value = A3 'Start
Range("U" & i).Value = A4 'End
Range("V" & i).Value = A5 'Percentage
End Sub
Function UpdateStartDate(ByVal i As Integer) As Range
Dim j As Integer
Dim A3 As Range
Range("E" & i).Select
j = ActiveCell.Column
While (ActiveCell.Value = 0)
j = j + 4
Cells(i, j).Select
Wend
Set UpdateStartDate = Cells(2, j)
End Function
Function UpdateEndDate(ByVal i As Integer) As Range
Dim j As Integer
Dim A4 As Range
Range("G" & i).Select
j = ActiveCell.Column
While (ActiveCell.Value = 0)
j = j + 4
Cells(i, j).Select
Wend
Set UpdateEndDate = Cells(2, j)
End Function
Function UpdatePercent(ByVal i As Integer) As Range
Dim j As Integer
Dim A5 As Range
Range("G" & i).Select
j = ActiveCell.Column
While (ActiveCell.Value = 0)
j = j + 4
Cells(i, j).Select
Wend
Set UpdatePercent = Cells(i, j)
End Function
I have multiple Excel workbooks that contain about 8,000 rows so it would be nice to use a macro.
Basically, if any row has a zero (0) in all columns (at the same time) B, D, E, I, J, and K it will delete.
Here is what I have so far...way too new with VB to figure out.
Sub DeleteRowsZeros()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
If (Range("B") = "0" And Range("D" & i) = "0" And Range("E" & i) = "0" And Range("I" & i) = "0" _
And Range("J" & i) = "0" And Range("K" & i) = "0") Then Rows(i).Delete
Next i
End Sub
Try this :
Sub DeleteRowsZeros()
Dim cell As Range, notZeroColumns As Range, row As Range
Set row = Range("A" & Rows.Count).End(xlUp).EntireRow.Offset(1, 0)
Set notZeroColumns = Range("B:B,D:E,I:k")
While row.row <> 1
Set row = row.Offset(-1, 0)
For Each cell In Intersect(row, notZeroColumns)
If cell.Text <> "0" Then GoTo continueLbl
Next
row.Offset(1, 0).Delete
continueLbl:
Wend
End Sub
EDIT : bugfixe