I wnat to do some grouping in excel using VBA
My "criteria" column is "A" which is general a list of number that are obviously redundant and should be grouped to give the user a better understanding of the excel sheet
I have named column "A" "Vertrag__Nr."
My Code
Sub Test()
Dim i As Integer, LastRow As Integer
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
If Not Left(Cells(i, 1), 2) = "Vertrag__Nr." Then
Cells(i, 2).EntireRow.Group
End If
Next i
End Sub
My problem is that my code instead of grouping by entries "Vertrag _Nr." (Column A) In groups the whole column into one big groupe
as grouping is used for summaries, there has to be a place for summary between groups, they cannot be contiguous, try this code:
Sub Test()
Dim i As Integer, j As Integer, LastRow As Integer
Dim currVal As Variant
With ActiveSheet
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
i = 2
While i <= LastRow
currVal = .Cells(i, 1).Value
j = 0
Do
j = j + 1
Loop Until .Cells(i + j, 1).Value <> currVal
If j > 1 Then
.Rows(i + j).Insert
.Cells(i + j, 1).Value = currVal
Range(.Cells(i, 1), .Cells(i + j - 1, 1)).EntireRow.Group
End If
i = i + j
Wend
End With
End Sub
Related
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
I am trying to write code that would shift the range of cells from the current cell till the last cell that has data in the row one cell to the right if the relative cell that contains the weekday has the values fri or sat.
My code is below, however when it runs, Excel would not respond and restarts by itself. I don't really know where the problem is.
Note: i is the row index, j is the column index
Sub shiftcell()
Dim i As Integer
Dim j As Integer
Dim lcol As Integer
Dim rng As Range
For i = 8 To 18
For j = 6 To 70
If (Sheets("master").Cells(6, j).Value = "Fri" Or
Sheets("master").Cells(6, j).Value = "Sat") Then
lcol = Sheets("MASTER").Cells(i, Columns.COUNT).End(xlToLeft).Column
Set rng = Range(Cells(i, j), Cells(i, lcol))
rng.Cut rng.Cells(i).Offset(0, 1)
End If
Next j
Next i
End Sub
This should work for you (you can omit the second loop over the rows by selecting the whole range at once, as long as the rows have the same length. Otherwise bring back the row loop but inside the if environement):
Sub shiftcell()
Dim j, lcol As Long
Dim rngFrom, rangeTo As Range
For j = 6 To 70
If ((Sheets("master").Cells(6, j).Value = "Fri") Or (Sheets("master").Cells(6, j).Value = "Sat")) Then
lcol = Sheets("master").Cells(8, Columns.Count).End(xlToLeft).Column
If (lcol >= j) Then
Set rngFrom = Range(Cells(8, j), Cells(18, lcol))
Set rngTo = Range(Cells(8, j + 1), Cells(18, lcol + 1))
rngFrom.Cut rngTo
End if
End If
Next j
End Sub
So I have a master sheet with 1000+ rows and another sheet that "should" have the same data. however, in reality sometimes some is missing from the master and sometimes some is missing from the query run.
for simplicity purposes let's say the unique ID is in column B. here's my code but it's super slow and it only does a 1-way comparison.
My ideal code would be something that runs a little smoother and gives me the missing data from both the master and the query.
Is there's something wrong with the way I'm asking the question please let me know.
Sub FindMissing()
Dim lastRowE As Integer
Dim lastRowF As Integer
Dim lastRowM As Integer
Dim foundTrue As Boolean
lastRowE = Sheets("Master").Cells(Sheets("Master").Rows.Count, "B").End(xlUp).Row
lastRowF = Sheets("Qry").Cells(Sheets("Qry").Rows.Count, "B").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Sheets("Mismatch").Rows.Count, "B").End(xlUp).Row
For i = 1 To lastRowE
foundTrue = False
For j = 1 To lastRowF
If Sheets("Master").Cells(i, 2).Value = Sheets("Qry").Cells(j, 2).Value Then
foundTrue = True
Exit For
End If
Next j
If Not foundTrue Then
Sheets("Master").Rows(i).Copy Destination:= _
Sheets("Mismatch").Rows(lastRowM + 1)
lastRowM = lastRowM + 1
End If
Next i
End Sub
Don't loop through the cells on the worksheet. Collect all of the values into variant arrays and process in-memory.
Option Explicit
Sub YouSuckAtVBA()
Dim i As Long, mm As Long
Dim valsM As Variant, valsQ As Variant, valsMM As Variant
With Worksheets("Master")
valsM = .Range(.Cells(1, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
With Worksheets("Qry")
valsQ = .Range(.Cells(1, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
ReDim valsMM(1 To (UBound(valsM, 1) + UBound(valsQ, 1)), 1 To 2)
mm = 1
valsMM(mm, 1) = "value"
valsMM(mm, 2) = "missing from"
For i = LBound(valsM, 1) To UBound(valsM, 1)
If IsError(Application.Match(valsM(i, 1), valsQ, 0)) Then
mm = mm + 1
valsMM(mm, 1) = valsM(i, 1)
valsMM(mm, 2) = "qry"
End If
Next i
For i = LBound(valsQ, 1) To UBound(valsQ, 1)
If IsError(Application.Match(valsQ(i, 1), valsM, 0)) Then
mm = mm + 1
valsMM(mm, 1) = valsQ(i, 1)
valsMM(mm, 2) = "master"
End If
Next i
valsMM = helperResizeArray(valsMM, mm)
With Worksheets("Mismatch")
With .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
.Resize(UBound(valsMM, 1), UBound(valsMM, 2)) = valsMM
End With
End With
End Sub
Function helperResizeArray(vals As Variant, x As Long)
Dim arr As Variant, i As Long
ReDim arr(1 To x, 1 To 2)
For i = LBound(arr, 1) To UBound(arr, 1)
arr(i, 1) = vals(i, 1)
arr(i, 2) = vals(i, 2)
Next i
helperResizeArray = arr
End Function
You cannot resize the first rank of a 2D array so I've added a helper function that will resize the results before putting them back into the Mismatch worksheet.
I have a column of data in excel which could potentially have data over 2000 rows. In that data there is groups of data that I would like to send to the top of a new column every time a new group is found. I've looked at the special paste option for transpose along with using a delimiter but i can only move data one column over and not to the top. I'm looking for a solution which is fast due to the amount of data that would need to be split into new columns. I appreciate the help.
Below is a table of how the data looks.
Below is how I would like the data to look
Try this simple code,
Sub splitRange()
Dim i As Long, j As Long, k As Long
Cells(1, 6) = Cells(1, 1)
Cells(1, 7) = Cells(1, 2)
j = 1
k = 6
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = Cells(i - 1, 1) Then
j = j + 1
Cells(j, k) = Cells(i, 1)
Cells(j, k + 1) = Cells(i, 2)
Else
k = k + 3
j = 1
Cells(j, k) = Cells(i, 1)
Cells(j, k + 1) = Cells(i, 2)
End If
Next i
End Sub
Modify the code if you want the output in a separate sheet. I would like you to google it to learn about it.
I had to do something similar. You can try also this code:
Sub Move_Data()
Application.ScreenUpdating = False
Dim r As Integer
Dim StartRow As Integer
Dim EndRow As Integer
Dim ColA As Integer
Dim vLastRow As Integer
Dim vEnd As Integer
r = 1
StartRow = 1
EndRow = 1
ColA = 4
vEnd = 1
vLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
Do Until Cells(r, 1) <> Cells(StartRow, 1)
DoEvents
r = r + 1
Loop
vEnd = r
Do Until r > vLastRow
DoEvents
StartRow = r
Do Until Cells(r, 1) <> Cells(StartRow, 1)
DoEvents
r = r + 1
Loop
EndRow = r - 1
Range(Cells(StartRow, 1), Cells(EndRow, 2)).Select
Selection.Copy
Cells(1, ColA).Select
ActiveSheet.Paste
ColA = ColA + 3
Loop
r = vEnd + 1
Range(Cells(vEnd, 1), Cells(vLastRow, 2)).ClearContents
Cells(1, 1).Select
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
I'm trying to run a For Next Loop until the last row of a specific column (but not the last row of the sheet). So the first part of my list has data in column F and the second part doesn't. I only want the macro to apply to that first part. For some reason the loop only runs through the first part with certain commands but doesn't with the ones I am trying to do now. (I know it would be easy just to seperate the two parts manually and then run it but it drives me nuts not knowing what it is I did wrong :)).
This is the code:
Dim i As Integer
Dim g As Double
g = 0.083333333
Dim lastrow As Long
lastrow = Sheets("zm").Range("f" & Rows.Count).End(xlUp).Row
Sheets("zm").Activate
For i = 2 To lastrow
If Sheets("zm").Cells(i, 1) = Sheets("zm").Cells(i + 1, 1) And Sheets("zm").Cells(i, 5) = Sheets("zm").Cells(i + 1, 5) And Sheets("zm").Cells(i + 1, 6) - Sheets("zm").Cells(i, 7) < g Then
Sheets("zm").Cells(i + 1, 7).Copy
Sheets("zm").Cells(i, 7).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("zm").Rows(i + 1).Delete
End If
Next i
Thanks for your help!
avoid Select/Selection and/or Activate/ActiveXXX
try this:
Option Explicit
Sub main()
Dim i As Long, lastrow As Long
Dim g As Double
g = 0.083333333
With Worksheets("zm")
lastrow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = lastrow To 2 Step -1
If .Cells(i, 1) = .Cells(i + 1, 1) And .Cells(i, 5) = .Cells(i + 1, 5) And .Cells(i + 1, 6) - .Cells(i, 7) < g Then
.Cells(i + 1, 7).Copy Destination:=.Cells(i, 7)
.Rows(i + 1).Delete
End If
Next i
End With
End Sub