I have 16k rows of data. There are two columns with time. What i need is to find rows where time doesn't match and move everyhing below in last 3 columns down on one, so at the end I'll have all rows with time match and those that dont would have last 3 columns blank in that row.
here what I have so far, but I'm new to VBA and this doesnt work(
Sub timeline()
Dim y As Long
With ThisWorkbook.Sheets("L5")
y = .Range("G" & .Rows.Count).End(xlUp).Row
End With
x = 2
Do While ThisWorkbook.Sheets("L5").Cells(x, 4) <> ""
If ThisWorkbook.Sheets("L5").Cells(x, 4).Value = ThisWorkbook.Sheets("L5").Cells(x, 7).Value Then
Else: ThisWorkbook.Sheets("L5").Range("Gx:Iy").Select
Selection.Offset(1, 0).Select
y = y + 1
End If
x = x + 1
Loop
The following code should do it. Check whether the right ranges and cells are used; I tried to figure it out from your code:
Sub timeline()
Dim y As Long
With ThisWorkbook.Sheets("L5")
y = .Range("G" & .Rows.Count).End(xlUp).Row
End With
x = 2
Do While ThisWorkbook.Sheets("L5").Cells(x, 4) <> ""
If ThisWorkbook.Sheets("L5").Cells(x, 4).Value = ThisWorkbook.Sheets("L5").Cells(x, 7).Value Then
' nothing
Else
ThisWorkbook.Sheets("L5").Range("G" & Trim(Str(x)) & ":I" & Trim(Str(y))).Cut
ThisWorkbook.Sheets("L5").Range("G" & Trim(Str(x + 1))).Select
ThisWorkbook.Sheets("L5").Paste
y = y + 1
End If
x = x + 1
Loop
End Sub
Related
I have 1000s rows of data in 1 column that I need to transpose into columns, based on each row that is bold. The number of rows between bold ones is inconsistent, same as strings values.
I've created a simple code that worked perfectly while testing the first 100 rows. But when trying to run it through the entire list or some other parts (even 50 rows) it just stucks while running so I have to quite excel via task manager (with no error msg).
Sub Transpose_by_bold()
Dim x, y As Integer
y = 1
For x = 1 To 2000
If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = True Then y = 1
If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = False Then
Range("B" & x + 1).Cut Range("B" & x).Offset(0, y)
Range("B" & x + 1).EntireRow.Delete
y = y + 1
x = x - 1
End If
Next x
End Sub
I'd highly appreciate if you could give me a piece of idea what's wrong here?
Your code is currently hanging because once it moves to the end of the list X never increases, so it goes into an infinite loop. I've not tested FaneDuru's code, so it may be the answer, but the other choice would be to add some kind of escape clause to your code that bounces you out in the event of some condition you don't expect to ever happen naturally in your code - like a counter if range("b" & x).value = "" that gets reset when not true and, upon getting to some maximum value (say, 10 back to back empty cells) sets X equal to your max value (2000, in this case).
Don't forget, in the presence of weird stuff like this, you can step through your code with F8 and watch your values of X and Y in the Locals Window - if you do that, the fact that X gets stuck becomes quickly apparent.
sample counter (not terribly efficient, but it works):
Sub Transpose_by_bold()
Dim x, y As Integer
Dim Counter as Integer
y = 1
For x = 1 To 2000
If IsEmpty(Range("B" & x + 1)) Then
Counter = Counter + 1
Else
Counter = 0
End If
If Counter > 9 Then
x = 2001
End If
If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = True Then y = 1
If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = False Then
Range("B" & x + 1).Cut Range("B" & x).Offset(0, y)
Range("B" & x + 1).EntireRow.Delete
y = y + 1
x = x - 1
End If
Next x
End Sub
An alternate choice, I just realized (editing to note this), would be to count the maximum possible number of rows via an intersect of your column of interest and the used range of the sheet and then keep a counter that just checks how many total rows you've evaluated (your X counter right now is how many rows you'l end up with, not how many you've looked at, due to your x=x-1 line) and run your primary For loop on that total rows counter rather than on X.
Good luck!
Try the next code, please. I hope I could deduce the logic of your code. Especially, how to use y (incrementing the column to copy the range for each occurrence)... If the logic is correct, the code should be fast, deleting all rows at once:
Sub Transpose_by_bold()
Dim sh As Worksheet, x As Long, y As Long, rngDel As Range
Set sh = ActiveSheet 'use here your sheet
y = 1
For x = 1 To 2000
If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = True Then y = 1
If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = False Then
Range("B" & x).Offset(0, y).Value = Range("B" & x + 1).Value
If rngDel Is Nothing Then
Set rngDel = Range("B" & x + 1)
Else
Set rngDel = Union(rngDel, Range("B" & x + 1))
End If
y = y + 1
End If
Next x
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub
I am trying to create a program that deletes all rows without information in columns B-G and then rearranges the data from a vertical orientation to a horizontal one.
The data is only in columns A-G arranged so that every couple rows (the number is not constant), a row of dates appears. I want every row with dates to be pasted horizontally from each other and all of the data in between the dates to move corresponding with their dates (including column A).
The part that deletes empty rows works well. However, as I tried to write the rearrangement program, I kept on getting an
"Object Required"
error that appeared in the sub line (AKA the first line). Can someone help me resolve this issue? The code is pasted below.
Sub MovingDeletion()
Set rngRange = Selection.CurrentRegion
lngNumRows = rngRange.Rows.Count
lngFirstRow = rngRange.Row
lngLastRow = lngFirstRow + lngNumRows - 1
columns("B").Select
lngCompareColumn1 = ActiveCell.Column
columns("C").Select
lngCompareColumn2 = ActiveCell.Column
columns("D").Select
lngCompareColumn3 = ActiveCell.Column
columns("E").Select
lngCompareColumn4 = ActiveCell.Column
columns("F").Select
lngCompareColumn5 = ActiveCell.Column
columns("G").Select
lngCompareColumn6 = ActiveCell.Column
columns("A").Select
lngCompareColumn7 = ActiveCell.Column
Set MedicationRow = 0
'Deletion Code (Works Fine)
For lngCurrentRow = lngLastRow To lngFirstRow Step -1
Mrow = True
If (Cells(lngCurrentRow, lngCompareColumn1).Text = "" And Cells(lngCurrentRow, lngCompareColumn2).Text = "" And Cells(lngCurrentRow, lngCompareColumn3).Text = "" And Cells(lngCurrentRow, lngCompareColumn4).Text = "" And Cells(lngCurrentRow, lngCompareColumn5).Text = "" And Cells(lngCurrentRow, lngCompareColumn6).Text = "") Then _
Rows(lngCurrentRow).Delete
'Rearrangement Code (Does not work. Gives Object Requiered error)
Dim counter As Integer
Dim NextRow As Integer
Dim i As Integer
i = lngCurrentRow
counter = 0
Number = 0
If (Cells(lngCurrentRow, lngCompareColumn7).Text <> "Days") Then
counter = counter + 1
If counter > 1 Then
NextRow = lngCurrentRow - 1
While (Cells(NextRow, lngCompareColumn7).Text <> "Days")
NextRow = NextRow - 1
Number = Number + 1
Wend
End If
Range("A" & CStr(i) & ":G" & CStr(NextRow)).Cut Range("H1" & CStr(i) & ":P" & CStr(NextRow))
End If
Next lngCurrentRow
End Sub
I have created a nested for loop to compare 3 different cell values within 2 sheets. The loop works fine when the data is small, but when I run on 5,000 rows its too slow and crashes excel. Any idea of how to run this more efficiently.
Sub RowMatch()
Dim x As Integer
' Make sure we are in the right sheet
Worksheets("Q416").Activate
' Set numrows = number of rows of data.
NumRows = Range("C2", Range("C2").End(xlDown)).Rows.count
' find the reference range
Worksheets("Q415").Activate
NumRows2 = Range("C5", Range("C5").End(xlDown)).Rows.count
Worksheets("Q416").Activate
MsgBox ("Total # of Rows on this sheet = " & NumRows & " and " & NumRows2 & " in Ref Range")
Range("A1").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
'MsgBox NumRows2
For y = 1 To NumRows2
'MsgBox (ActiveCell.Offset(x, 0).Value & " & " & Worksheets("Q415").Cells(y + 1, 1))
If ActiveCell.Offset(x, 0).Value = Worksheets("Q415").Cells(y + 1, 1).Value _
And ActiveCell.Offset(x, 2).Value = Worksheets("Q415").Cells(y + 1, 3).Value Then
If ActiveCell.Offset(x, 5).Value = Worksheets("Q415").Cells(y + 1, 6).Value Then
'If NumRows(i).Value = ActiveCell.Offset(1, 0).Value Then
ActiveCell.Offset(x, 10).Value = "Same"
Else
ActiveCell.Offset(x, 10).Value = ActiveCell.Offset(x, 5).Value - Worksheets("Q415").Cells(y + 1, 6).Value
End If
End If
Next y
Next x
End Sub
Reading and writing to cells is one of the slowest operations you can do in Excel VBA. Instead, you should place the values contained in the worksheets into arrays and work with them there, Here is an excellent reference: http://www.cpearson.com/excel/ArraysAndRanges.aspx. Use your NumRows variables and either a column letter or number to define the ranges that will consitute the arrays e.g:
myRange = Range("A1:C" & NumRows)
myArray = myRange.value
From the link to Chip Pearsons site:
Dim Arr() As Variant
Arr = Range("A1:B10")
Dim R As Long
Dim C As Long
For R = 1 To UBound(Arr, 1) ' First array dimension is rows.
For C = 1 To UBound(Arr, 2) ' Second array dimension is columns.
Debug.Print Arr(R, C)
Next C
Next R
I need to loop over all rows (except my header rows) and merge all cells with the same value in the same column. Before I do this I already made sure, that the column is sorted.
So I have some setup like this.
a b c d e
1 x x x x
2 x x x x
2 x x x x
2 x x x x
3 x x x x
3 x x x x
And need this
a b c d e
1 x x x x
2 x x x x
x x x x
x x x x
3 x x x x
x x x x
With my code I achieved to merge two equal cells. Instead I need to merge all equal cells.
Dim i As Long
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(i, 1) <> "" Then
If Cells(i, 1) = Cells(i - 1, 1) Then
Range(Cells(i, 1), Cells(i - 1, 1)).Merge
End If
End If
Next i
This method does not use merged cells, but achieves the same visual effect:
Say we start with:
Running this macro:
Sub HideDups()
Dim N As Long, i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 3 Step -1
With Cells(i, 1)
If .Value = Cells(i - 1, 1).Value Then
.Font.ColorIndex = 2
End If
End With
Next i
End Sub
will produce this result:
NOTE:
No cells are merged. This visual effect is the same because consecutive duplicates in the same column are "hidden" by having the colour of the font be the same as the colour of the cell background.
I know this is an old thread, but I needed something similar. Here's what I came up with.
Sub MergeLikeCells()
Dim varTestVal As Variant
Dim intRowCount As Integer
Dim intAdjustment As Integer
ActiveSheet.Range("A1").Select
'Find like values in column A - Merge and Center Cells
While Selection.Offset(1, 0).Value <> ""
'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
intRowCount = 1
varTestVal = Selection.Value
While Selection.Offset(1, 0).Value = varTestVal
intRowCount = intRowCount + 1
Selection.Offset(1, 0).Select
Selection.ClearContents
Wend
intAdjustment = (intRowCount * -1) + 1
Selection.Offset(intAdjustment, 0).Select
Selection.Resize(intRowCount, 1).Select
With Selection
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Offset(1, 0).Resize(1, 1).Select
Wend
End Sub
My solution as below, have a good day!
Sub MergeSameValue()
Application.DisplayAlerts = False
Dim LastRow As Integer
Dim StartRow As Integer
StartRow = 2
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim StartMerge As Integer
StartMerge = StartRow
For i = StartRow + 1 To LastRow
If Cells(i, 1) <> "" Then
If Cells(i, 1) <> Cells(i - 1, 1) Then
Range(Cells(i - 1, 1), Cells(StartMerge, 1)).Merge
StartMerge = i
End If
End If
Next i
End Sub
In my worksheet some cells values are based on other cells
Info worksheet
A1: 5
B1: =A1
Design worksheet
A1:
Is there a way to copy and read the value in B1? I'm trying to use the value in a for loop, with no luck.
Sheets("Info").Select
For i = 1 to 5
If Range("B" & i).Value <> 0 Then
Range("B" & i).Copy Destination:=Sheets("Design").Range("A" & x)
'Sheets("Design").Range("A" & x).Value = Sheets("Offerte").Range("B" & i).Value
x = x + 1
End If
Next i
Your example doesn't seem to match the code well. The line
If Range("B" & i).Value = 1 Then
means that nothing will be copied in your example. It's looking for a cell with 1 in it. Why do you need that If statement at all?
EDIT I am guessing you're just checking that there's something in the cell to copy? I would probably do it this way:
If Trim(Range("B" & i).Value) <> "" Then
Also - did you miss out setting x=1?
There is more than one way to do it. One of them is using 'offset', which is a function that really worth understand. It basically points to a amount of rows / columns from the original cell.
Sub test()
Dim oCell As Excel.Range
Dim i As Integer
Dim x As Integer
Set oCell = Sheets("Info").Range("B1")
x = 1
For i = 1 To 5
If oCell.Offset(i, 0).Value = 1 Then
oCell.Offset(i, 0).Copy Destination:=Sheets("Design").Range("A" & x)
x = x + 1
End If
Next i
End Sub
Besides, you can assert the value instead of using the copy property. Notice it won't work unless x is an integer > 0.
Sub test2()
Sheets(3).Select
x = 1
For i = 1 To 5
If Range("B" & i).Value = 1 Then
Sheets(4).Range("A" & x).Value = Range("B" & i).Value
'Sheets("Design").Range("A" & x).Value = Sheets("Offerte").Range("B" & i).Value
x = x + 1
End If
Next i
End Sub