Can anybody please help me figure out my problem?
I have this code that I would like to move to the next column if the condition is not met.I'm stuck and don't know where to proceed.
Dim lrow3, lrow1 as long
dim dDate as Date
dim yrNum, j as Integer
dDate = Format(Now(),"mm/dd/yyyy")
lrow3 = ActiveSheet.Cells(Rows.count, 2).End(xlUp).Row
lrow1 = Sheets("Sample").Cells(Rows.count, 2).End(xlUp).Row
for j = 2 to lrow1
For yrNum = 1 To 100
If DateValue(Format(Range("Q" & j).Value, "mm/dd/yyyy")) >= DateValue(dDate) And _
DateValue(Format(Range("R" & j).Value, "mm/dd/yyyy")) <= DateValue(dDate) Then
ActiveSheet.Range("D" & lrow3 + 1).Value = Range("T" & j).Value
ActiveSheet.Range("E" & lrow3 + 1).Value = Range("U" & j).Value
Exit For
Else
Range("Q" & j) = ActiveCell
Range("Q" & j) = ActiveCell.Offset(0, 9)
'after executing this is I have to set this offsetted cell to be the active one
'on which i will be referring in the next loop
End If
Next yrNum
next j
In the snippet, if the value in Q & j does not met the requirements, then i have to check the 9th letter after Q which is Z and so on.
By the way what I'm comparing on this are date values in the cell.
A few observations
dDate = Format(Now(),"mm/dd/yyyy") is the same as dDate = Date
DateValue(Format(Range("Q" & j).Value, "mm/dd/yyyy")) is the same asDateValue(Range("Q" & j).Value)`
You are starting in column Q and if the conditions are not meet you move over 9 columns and check again. You do this 100 times. The final column is column 917(column letter code AIG)
Sub RefactoredCode()
Dim lrow3, lrow1 As Long
Dim DateRange As Range
Dim wsSample As Worksheet
Dim yrNum, j As Integer, iOffset As Integer
Set wsSample = Worksheets("Sample")
lrow3 = Cells(Rows.Count, 2).End(xlUp).Row
lrow1 = wsSample.Cells(Rows.Count, 2).End(xlUp).Row
For j = 2 To lrow1
For yrNum = 1 To 100
iOffset = (yrNum * 9) - 9
Set DateRange = wsSample.Cells(j, "Q").Offset(0, iOffset)
If DateValue(DateRange.Value) >= Date And _
DateValue(DateRange.Offset(0, 1).Value) <= Date Then
lrow3 = lrow3 + 1
Range("D" & lrow3).Value = wsSample.Cells(j, "T").Offset(0, iOffset).Value
Range("E" & lrow3).Value = wsSample.Cells(j, "U").Offset(0, iOffset).Value
Exit For
End If
Next yrNum
Next j
End Sub
Related
I have this code
Sub ExpandRanges()
Dim X As Long, CG As Variant, Rng As Range, Cell As Range
Dim Series As String, CommaGroups() As String, DashGroups() As String
Set Rng = Range(Range("H2"), Cells(Rows.Count, "H").End(xlUp))
For Each Cell In Rng
CommaGroups = Split(Cell, ",")
For Each CG In CommaGroups
DashGroups = Split(CG, "-")
For X = DashGroups(0) To DashGroups(UBound(DashGroups))
Series = Series & ", " & X
Next
Next
Cell.Offset(, 1).Value = Mid(Series, 3)
Series = ""
Next
End Sub
That gives me and output of:
Can anyone reformat the code to where it creates a new row for each number that is expanded from the range? Rather than expanding them out into a new column to where I have to separate them again manually.
I would like for it to look like this (referring to the first range)
Try this:
EDIT: Fixed
Sub ExpandRanges()
Dim X As Long, CG As Variant, Rng As Range, Cell As Range
Dim Series As String, CommaGroups() As String, DashGroups() As String
Dim j As Long, lastrow As Long, newrow as Long
j = 0
lastrow = Cells(Rows.Count, "H").End(xlUp).Row
newrow = InputBox("What is the row number of your new range?")
Set Rng = Range(Range("H" & newrow), Range("H" & lastrow))
For Each Cell In Rng
CommaGroups = Split(Cell, ",")
For Each CG In CommaGroups
DashGroups = Split(CG, "-")
For X = DashGroups(0) To DashGroups(UBound(DashGroups))
If j = 0 Then j = Split(Cell.Address, "$")(2)
Rows(j + 1 & ":" & j + 1).Insert Shift:=xlDown
Cells(j, 9).Value = X
Range("C" & j + 1 & ":H" & j + 1).Value = Range("C" & j & ":H" & j).Value
j = j + 1
Next
Next
Next
'Band-aid solution
lastrow = Cells(Rows.Count, "H").End(xlUp).Row
Range("C" & lastrow & ":H" & lastrow).ClearContents
End Sub
I´m pretty new to VBA and since it´s making my job so much easier I try to write some codes from time to time and everything works fine except for this one, I already tried with the Screen Updating and the Status Bar method but it´s still very slow. Any ideas on how it coul be improved? Thnak you
Sub DW()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
i = 1
Do Until i > LastRow
If Range("B" & i) = Range(B & i + 1) Then
Range("L" & i) = Range("L" & i) + Range("L" & i + 1)
Range("M" & i) = Range("M" & i) + Range("M" & i + 1)
Range("N" & i) = Range("N" & i) + Range("N" & i + 1)
Range("O" & i) = Range("O" & i) + Range("O" & i + 1)
Range("P" & i) = Range("P" & i) + Range("P" & i + 1)
Range("Q" & i) = Range("Q" & i) + Range("Q" & i + 1)
Range("A" & i + 1).EntireRow.Delete
LastRow = LastRow - 1
Else
i = i + 1
End If
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
This does what your code does; i tested with 1k rows of data and it was faster then your code. (Updated with ja72's input)
Dim i As Long
Dim LastRow As Long
If Range("B1") = Range("B2") Then
Rows(1).Copy
Rows(1).Insert Shift:=xlDown
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(1, 12).Formula = "=SUM(L2:L" & LastRow & ")"
Cells(1, 12).Resize(, 5).FillRight
End If
Range("L1").Resize(1,10).Value = Range("L1").Resize(1,10).Value
Rows(2 & ":" & Rows.Count).Delete
The code below first addresses the issue of string math for the range picking. Instead of .Range("A" & i) it best to use .Offset() or .Cells() instead. Additionally it makes it explicit that we are dealing with values and not ranges when the math takes place. It is recommended to always type .Value where it is implied.
Sub DW()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Dim i As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim r As Range, g As Range
' Set the start of the optimization loop
Set r = Range("B1")
' While still inside the data
Do While r.Row <= LastRow
' Check this value with value of next row
If r.Value = r.Offset(1, 0).Value Then
Set g = r.Offset(0, 10) ' Pick column "L" of same row as r
Go from "L" to "Q"
For i = 1 To 6
'Add values one by one with row below
g.Offset(0, i - 1).Value = _
g.Offset(0, i - 1).Value + g.Offset(1, i - 1).Value
Next i
r.Offset(1, 0).EntireRow.Delete
LastRow = LastRow - 1
End If
' Move to next row
Set r = r.Offset(1, 0)
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
End Sub
Depending on the total amount of data, it will be way faster to load all the data into memory and process it with VBA arrays only to be returned back in the end to the worksheet.
The following code should be orders of magnitude faster.
Sub DW2()
Dim i As Long, j As Long, i_out As Long, i_next As Long
Dim LastRow As Long, ValCol As Long, LastCol As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
ValCol = Cells(, "L").Column
LastCol = Cells(, "Q").Column
Dim r_data As Range
' Reference all the data (filled rows, and 17 columns "A:Q")
Set r_data = Range("A1").Resize(LastRow, LastCol)
' x is input data, y as output data
Dim x() As Variant, y() As Variant
' Copy all the table cells into memory
x = r_data.Value
' Create an empty array at least the same size
ReDim y(1 To LastRow, 1 To LastCol)
' i_out is index for output
i_out = 1
' i is index for input
For i = 1 To LastRow
' Debug.Print "Row"; i, "into Row:"; i_out
'Copy all values first from current row
For j = 1 To LastCol
y(i_out, j) = x(i, j)
Next j
' Index i_next peeks at the next row
i_next = i + 1
If i_next >= LastRow Then
' Advance i_out
i_out = i_out + 1
Exit For
End If
' Check with value match on 2nd column "B"
Do While x(i, 2) = x(i_next, 2)
'Add up values in columns 11 through 17
For j = ValCol To LastCol
y(i_out, j) = y(i_out, j) + x(i_next, j)
Next j
' Peek at subsequent rows also
i_next = i_next + 1
If i_next >= LastRow Then
' Advance i_out
i_out = i_out + 1
Exit For
End If
Loop
' Advance i if rows were skipped
i = i_next - 1
' Advance i_out
i_out = i_out + 1
Next i
' Clear all table cells
r_data.ClearContents
' Overwrite with the optimized values
r_data.Resize(i_out - 1, LastCol).Value = y
End Sub
Edit: Now tested for robustness when matching rows exist in the end of the data
I have an array of data, a screenshot of it will be linked at the bottom of this text. Row and column references are to the screenshot.
I am trying to write a macro that will output all the dates that occur within the dynamic range (Column H). And then in column I I want the column header # row i.e I4.
But if there is more than 1 count at the date, I would like the second school to output into column J. As it would for the date 26/03/18, looking like this:
h5 = 26/03/18 , i5(Event1) = Task 2 # 1, j5(Event2) = task 2 # 4
I have tried many ways today and would like some assistance.
Screenshot: https://ibb.co/cmiGSc
My Code thus far(For the more complex sheet):
Sub Events()
'How many schools there are
Dim sh As Worksheet
' This needs to change for each sheets
Set sh = ThisWorkbook.Sheets("Easter 18")
Dim k As Long
k = sh.Range("A3").End(xlDown).Row 'Counts up from bottow - Number of schools attained
Ro = Range("M52").value = k - 2 'Elimiates the two top rows as headers
'Now I need to search the Range of dates
Dim TaskDates As Range
Dim StartCell As Range 'First part of Array
Dim EndCell As Range 'End of Array
Set EndCell = Range("J" & 2 + k) 'maybe 2 or 3
Set StartCell = Range("G3")
Set TaskDates = Range(StartCell, EndCell) 'Dynamic Range
'Within the range of data print out the most left row header (school name) - and task with # in the middle - ascending
' If Column has date (true) create a table with Date (col 1), Event (col 2), Event 2 (Col3) etc etc
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim varray As Variant, element As Variant
varray = TaskDates.value
'Generate unique list and count
For Each element In varray
If dict.exists(element) Then
dict.item(element) = dict.item(element) + 1
Else
dict.Add element, 1
End If
Next
'Paste report somewhere -
'First line ouptuts the dates occured
sh.Range("M55").Resize(dict.Count).value = 'Was working now saying syntax error for this line.
WorksheetFunction.Transpose (dict.keys)
' The count works if cell format is correct
CDates = sh.Range("N55").Resize(dict.Count, 1).value = _
WorksheetFunction.Transpose(dict.items)
End Sub
Please feel free to redesign it if you see fit.
you can go this way
Option Explicit
Sub Tasks()
Dim cell As Range, f As Range
With Worksheets("schools") 'change "schools" to your actual sheet name
For Each cell In .Range("C4:F" & .Cells(.Rows.Count, "B").End(xlUp).Row) 'reference its column C:F from row 4 down to column B last not empty cell
If IsDate(cell.value) Then 'if current cell value is a valid date
Set f = .Range("H3", .Cells(.Rows.Count, "H").End(xlUp)).Find(what:=cell.value, lookat:=xlWhole, LookIn:=xlValues) 'try finding the date in column H
If f Is Nothing Then Set f = .Cells(.Rows.Count, "H").End(xlUp).Offset(1) 'if date not already in column H then get its first empty cell after last not empty one
f.value = cell.value 'write the date (this is sometimes not necessary, but not to "ruin" the code)
.Cells(f.Row, .Columns.Count).End(xlToLeft).Offset(, 1).value = .Cells(3, cell.Column).value & " #" & .Cells(cell.Row, 2).value ' write the record in the first not empty cell in the "date" row
End If
Next
End With
End Sub
Took a shot at this. Just a couple nested loops testing against the dates, making sure that the date found isn't already listed under the date column. As I stated before, you never said what to do if more than 3 dates are found, so I had to add a fourth event column and assume that that's the max. Anything more than 4 dates won't be recorded anywhere, FYI.
Sub MoveDates()
Dim i As Long, j As Long, sht As Worksheet, lastrow As Long, lastrow2 As Long, refrow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row + 1
For i = 4 To lastrow
For j = 3 To 6
If Cells(i, j).Value <> "" And Cells(i, j).Value <> "n/a" Then
If Not Application.WorksheetFunction.CountIf(Range("H4:H" & lastrow), Cells(i, j)) > 0 Then
lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row + 1
Range("H" & lastrow2).Value = Cells(i, j).Value
If Range("I" & lastrow2).Value = "" Then
Range("I" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("J" & lastrow2).Value = "" Then
Range("J" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("K" & lastrow2).Value = "" Then
Range("K" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("L" & lastrow2).Value = "" Then
Range("L" & lastrow2).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
End If
Else
lastrow2 = sht.Cells(sht.Rows.Count, "H").End(xlUp).Row
For k = 4 To lastrow2
If Range("H" & k).Value = Cells(i, j).Value Then
refrow = k
Exit For
End If
Next k
If Range("I" & refrow).Value = "" Then
Range("I" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("J" & refrow).Value = "" Then
Range("J" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("K" & refrow).Value = "" Then
Range("K" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
ElseIf Range("L" & refrow).Value = "" Then
Range("L" & refrow).Value = Cells(3, j).Value & " # " & Cells(i, 2).Value
End If
End If
End If
Next j
Next i
End Sub
This is my first post, but I have an excel workbook with multiple tabs formatted like this:
I'm learning vba but don't know the excel functions well enough yet to loop through the rows and copy the data reformatted to a new sheet into this format:
Specifically I think i need to
- Initialize the range of worksheets
loop through them
store column headers for b through G into a variable so when the x is found it can be concatenated or copied over
handle the blank spaces so that the last value is used for each one
Any help appreciated. Thanks!
The following will do what you expect:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
Dim wsResult As Worksheet: Set wsResult = Sheets("Sheet2")
LastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row
'get the last row with data on Column J
For i = 2 To LastRow
NextRow = wsResult.Cells(wsResult.Rows.Count, "D").End(xlUp).Row + 1
ws.Range("H" & i & ":J" & i).Copy Destination:=wsResult.Range("D" & NextRow)
wsResult.Range("A" & NextRow).Value = "Title"
If ws.Cells(i, 1) <> "" Then 'if GroupID is not empty
wsResult.Range("B" & NextRow).Value = ws.Cells(i, 1) 'grab that GroupID
Else
x = i
Do While Trim(ws.Cells(x, 1)) = ""
x = x - 1
Group = ws.Cells(x, 1) 'get the GroupID of the Row above
Loop
wsResult.Range("B" & NextRow).Value = Group
End If
For y = 2 To 7
If ws.Cells(i, y) <> "" Then
Level = ws.Cells(1, y).Value
Exit For
End If
Next y
wsResult.Cells(NextRow, 3) = Level
Next i
End Sub
Try this:
Sub BuildTable()
Dim data(), i As Integer, j As Integer
data = Worksheets("Sheet1").Range("A2:J5").Value
For i = 1 To UBound(data)
With Worksheets("Sheet2")
.Range("A" & i) = "Title"
.Range("D" & i) = data(i, 8)
.Range("E" & i) = data(i, 9)
.Range("F" & i) = data(i, 10)
If i > 1 Then
.Range("B" & i) = IIf(data(i, 1) <> "", data(i, 1), .Range("B" & i - 1))
Else
.Range("B" & i) = data(i, 1)
End If
For j = 2 To 7
If data(i, j) = "x" Then
.Range("C" & i) = "Level" & j - 1
End If
Next j
End With
Next i
End Sub
You can use Power Query Excel 2010+ you can download and activate easily or by default in 2016 version. There you can transform your data and put it as a table or a pivot table:
I have three columns, one of them having all the staff list IDs, the second is having Front-Line staff IDs, The third is having the Back-office staff IDs, sometimes we change the task to some of them, to work in the different field, So His Staff ID has to disappear from Front-Line col and appear in Back-Office col instead. and Vice-Versa, and this will be done by selecting some of Column A staff, then it will loop through Col B and remove selection value(If found), then add these selected cells to Col B.
The same when we normalize, we select some staff from Col A, It should remove the staff IDs from Col B and add it to col C
All Staff | Front-line | Back-Office
15348 | 15348 | 15344
15347 | 15347 | 15345
15345 |
15344 |
What I've achieved so far.
Excuse me if my codes looks a little bit complex, that's the only way I know.
Dedicate Button (Dedicating 1st Col staffs to work as Back-office)
Dim found As Boolean
Dim i, j, mycount, dedlist As Integer
Dim firstempty As Long
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("L" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
found = False
Selection.Copy
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
Cells(firstempty, 8).Select
Cells(firstempty, 8).PasteSpecial Paste:=xlPasteValues
End With
With Sheets("StaffList")
firstempty = .Range("H" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("L" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
For i = 2 To mycount
For j = 2 To dedlist
With Sheets("StaffList")
If .Range("H" & i).Value = .Range("L" & j).Value Then
found = True
End If
End With
Next j
If found = False Then
dedlist = dedlist + 1
With Sheets("StaffList")
.Range("L" & dedlist).Value = .Range("H" & i).Value
End With
End If
found = False
Next i
' ActiveSheet.Range("$H$1:$H$500").RemoveDuplicates Columns:=1, Header:=xlYes
Range("A1").Select
Normalize Button (Normalizing 2nd Col staffs to get back working as Front-Line)
Dim CompareRange As Variant, x As Variant, y As Variant
Dim rng As Range
Dim found As Boolean
Dim i, j, mycount, dedlist As Integer
Dim firstempty As Long
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("H" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
found = False
Selection.Copy
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
Cells(firstempty, 13).Select
Cells(firstempty, 13).PasteSpecial Paste:=xlPasteValues
End With
With Sheets("StaffList")
firstempty = .Range("M" & .Rows.Count).End(xlUp).Row + 1
dedlist = .Range("H" & .Rows.Count).End(xlUp).Row
End With
mycount = firstempty - 1
For i = 2 To mycount
For j = 2 To dedlist
With Sheets("StaffList")
If .Range("M" & i).Value = .Range("L" & j).Value Then
.Range("H" & j).Value = ""
End If
End With
Next j
Next i
Range("A1").Select
This is the VBA implementation of the suggestion in comment:
Option Explicit
Public Sub UpdateStaffTasks()
Const FRNT = "Front-line", BACK = "Back-Office"
Dim selRow As Variant, lrSelRow As Long, ws As Worksheet, i As Long, j As Long
Dim usdRng As Variant, lrUsdRng As Long, red As Long, blu As Long
If Selection.Cells.Count = 1 And Selection.Row = 1 Then Exit Sub
Set ws = Selection.Parent
selRow = GetSelRows(Selection): lrSelRow = UBound(selRow): red = RGB(256, 222, 222)
usdRng = ws.UsedRange: lrUsdRng = UBound(usdRng): blu = RGB(222, 222, 256)
For i = 0 To lrSelRow
For j = i + 2 To lrUsdRng
If j = Val(selRow(i)) Then
If Len(usdRng(j, 1)) > 0 And Len(usdRng(j, 2)) > 0 Then
usdRng(j, 2) = IIf(usdRng(j, 2) = FRNT, BACK, FRNT)
With ws.Cells(j, 1).Resize(, 2).Interior
.Color = IIf(usdRng(j, 2) = FRNT, red, blu)
End With
Exit For
End If
End If
Next
Next
Selection.Parent.UsedRange = usdRng
End Sub
Public Function GetSelRows(ByRef selectedRange As Range) As Variant
Dim s As Variant, a As Range, r As Range, result As Variant
If selectedRange.Cells.Count > 1 Then
For Each a In selectedRange.Areas
For Each r In a.Rows
If r.Row > 1 And InStr(s, r.Row) = 0 Then s = s & r.Row & " "
Next
Next
GetSelRows = Split(RTrim$(s)): Exit Function
Else
GetSelRows = Array(selectedRange.Row): Exit Function
End If
End Function
Before and After: