I have a spreadsheet with a column filled with strings. There are sometimes several instances of one string (I've sorted it though so they're all grouped together) so I've created a macro that looks at the current row in the column, determines if its already been posted in the second worksheet, and if it has, it moves to the next row, if it hasn't it posts it and then moves on.
It works perfectly until the end where it completely ignores the last entry. The last entry is one of the instances where there's several of the same strings so the issue almost definitely isn't that its just ignoring the last row.
It's ignoring the last entry completely no matter how many times it repeats. New to vba so any help appreciated.
Sub RCFS()
Dim ProfCtr As String
Dim S2FreecellH As Long
Dim ProfCenCellH As Long
S2FreecellH = 3
ProfCenCellH = 2
ProfCtr = Cells(ProfCenCellH, 4)
Worksheets("Sheet2").Cells(S2FreecellH, 1).Value = ProfCtr
While IsEmpty(Cells(ProfCenCellH, 4).Value) = False
If Cells(ProfCenCellH, 4).Value <> ProfCtr Then
Worksheets("Sheet2").Cells(S2FreecellH, 1) = ProfCtr
S2FreecellH = S2FreecellH + 1
ProfCtr = Cells(ProfCenCellH, 4)
ProfCenCellH = ProfCenCellH + 1
Else
ProfCenCellH = ProfCenCellH + 1
End If
Wend
End Sub
Indeed, your loop needs to still flush the value of ProfCtr even when you reached the empty cell. You can make it work by looking ahead one row in your If condition (add + 1).
Also included a couple of other improvements:
Do While Not IsEmpty(Cells(ProfCenCellH, 4).Value)
If Cells(ProfCenCellH + 1, 4).Value <> ProfCtr Then
Worksheets("Sheet2").Cells(S2FreecellH, 1) = ProfCtr
S2FreecellH = S2FreecellH + 1
ProfCtr = Cells(ProfCenCellH, 4)
End If
ProfCenCellH = ProfCenCellH + 1
Loop
Let me see if I have this right
' Stop when you reach an empty cell
While IsEmpty(Cells(ProfCenCellH, 4).Value) = False
' If the cell's value matches the variable ProfCtr then
' ignore it and move to the next row.
If Cells(ProfCenCellH, 4).Value <> ProfCtr Then
' But if it -doesn't- match, then copy the variable
' ProfCtr to Sheet 2.
Worksheets("Sheet2").Cells(S2FreecellH, 1) = ProfCtr
' Increment your rows
S2FreecellH = S2FreecellH + 1
' Set the next bit of text to copy
ProfCtr = Cells(ProfCenCellH, 4)
ProfCenCellH = ProfCenCellH + 1
Else
ProfCenCellH = ProfCenCellH + 1
End If
Shouldn't you be setting Prof Ctr = Cells(ProfCenCelH, 4) BEFORE doing the copying over to Sheet2?
trincot has the correct answer. Here is an alternate technique, using built-in method, that will accomplish the same task.
With Worksheets("Sheet1")
.Range("D1", .Range("D" & .Rows.Count)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet2.Range("A1"), Unique:=True
End With
Related
I have existing script that does a major chunk of what I need. The script (from here: https://www.extendoffice.com/documents/excel/4054-excel-duplicate-rows-based-on-cell-value.html) basically inserts and then copies rows of data X number of times, where X is one of the fields in the table. It works well and the referenced page shows examples of the start and end points.
But when I run the script in Excel I go from ~2,000 lines in my table to ~40,000 lines. I need to modify all the duplicated rows (incremental dates) and so I am now attemting to also include new data into the table while the script runs that will allow me to change data in the duplicated rows... for example I can use the duplicate number 1, 2, 3, 4 and some simple formulas to change dates relative to a start point.
I expect that I will need some additional code inserted into the routine that will add data into a nominated column and do the auto incrementing from 1.
Having zero actual VBA skillz, ive no idea how to tackle the second part of my problem with the code I already have. Any help would be totally awesome !!
Sub CopyData()
'Updateby Extendoffice 20160922
Dim xRow As Long
Dim VInSertNum As Variant
xRow = 1
Application.ScreenUpdating = False
Do While (Cells(xRow, "A") <> "")
VInSertNum = Cells(xRow, "D")
If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
Range(Cells(xRow, "A"), Cells(xRow, "D")).Copy
Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "D")).Select
Selection.Insert Shift:=xlDown
xRow = xRow + VInSertNum - 1
End If
xRow = xRow + 1
Loop
Application.ScreenUpdating = False
End Sub
Try this code below, I used the same sample data on the link you provided. However on this code I created 2 worksheets, one for the raw data to be processed and one for the duplicate output including the increment of dates and duplicate number.
Sub duplicateData()
Dim rSH As Worksheet
Set rSH = ThisWorkbook.Sheets("RAW") 'Your raw data
Dim oSH As Worksheet
Set oSH = ThisWorkbook.Sheets("OUTPUT") 'Output data on another sheet
x = 2
For a = 2 To rSH.Range("A" & Rows.Count).End(xlUp).Row
For b = 1 To rSH.Cells(a, 4).Value '4 is the column of duplicate times
If b = 1 Then
For c = 1 To 4 'Number of your column
oSH.Cells(x, c).Value = rSH.Cells(a, c).Value
Next c
oSH.Cells(x, 5) = 1 'First instance, 5 is the column number of duplicate counter
Else
For c = 1 To 4 'Number of your column
oSH.Cells(x, c).Value = rSH.Cells(a, c).Value
Next c
oSH.Cells(x, 3).Value = CDate(oSH.Cells(x - 1, 3).Value) + 1 '3 is the column number of date to increment
oSH.Cells(x, 5).Value = CInt(oSH.Cells(x - 1, 5).Value) + 1 '5 is the column number of duplicate counter
End If
x = x + 1 'Increment Output row number
Next b
Next a
End Sub
I have a code that searches an excel fill for the word distance, takes the value of the cell next to it, paste it into a new cell, then sums all the cells up. Which works great, but i now need to find a way to only sum ever even row number. Does that make sense?
Sub Distance_Check()
Dim DistanceCheck As String
Dim DistanceNumber As String
Dim DistanceSum As String
Dim DistanceTotal As String
DistanceCheck = MsgBox("Would you like to check the distance?", vbYesNo)
If DistanceCheck = vbYes Then
If IsArray(fname) Then Workbooks.OpenText fname(1)
i = 1
findStr = "Distance"
Set foundCel = Range("A:A").Find(what:=findStr)
If Not foundCel Is Nothing Then
firstAddress = foundCel.Address
Do
Range("J" & i).Value = foundCel.Offset(0, 1).Value
Set foundCel = Range("A:A").FindNext(foundCel)
i = i + 1
Loop While Not foundCel Is Nothing And foundCel.Address <> firstAddress
End If
Set wkbSourceBook = ActiveWorkbook
DistanceNumber = i - 2
DistanceSum = WorksheetFunction.Sum(Range(Cells(2, 15), (Cells(DistanceNumber + 1, 15))))
DistanceTotal = DistanceSum / DistanceNumber
If DistanceNumber = Cells(2, 12) Then
MsgBox ("No error found wihin distance")
Else
MsgBox ("Error found with distance")
End If
Else
End If
Call Save_Data
End Sub
Would the way youd go about this be using a for loop on the
cells(DistanceNumber(j,+1)
Where j = 0,
j = j +2 ,
Until j > DistanceNumber,
Would that work? If so how would you go about it?
Thanks
A quick way to step through a loop in the desired increments is to use the Mod operator which divides two numbers and returns any remainder (e.g. 7 mod 2 = 1, as two sixes fit into seven, leaving one).
You can use the row property of the range you identify with the Find method, and since you want to jump by two the modulo should be zero:
If foundcel.Row Mod 2 = 0 Then Range("J" & i).value = foundcel.Offset(0, 1).Value
That said, there is a 'built in' way to step through a loop if using a For loop like this
For x = 2 to 10 Step 2
' Do stuff
Next x
You can also use this method to step backwards, e.g.
For x = 100 to 0 Step -10
' Do stuff backwards!
Next x
I have an excel spreadsheet. In a column of the spreadsheet I have a list of codes (numbers).These codes (numbers) are sorted from highest to lowest values.(some of these codes has been repeated. For example I have three consecutive line with code 1001200).I want to insert new rows between each codes (in case of having repeated codes i just need one new row (for example i Just need one new row for 1001200 not 3 rows) .
I have written the following code but it does not work.
Sub addspace()
Dim space_1(5000), Space_2(5000)
For n = 1 To 5000
Debug.Print space_1(n) = Worksheets("sheet3").Cells(1 + n, 1).Value
Debug.Print Space_2(n) = Worksheets("sheet3").Cells(2 + n, 1).Value
Next
For n = 1 To 5000
If space_1(n) <> Space_2(n) Then
Range("space_1(n)").EntireRow.Insert
End If
Next
End Sub
How can I fix it? (From the code you can see that I am so beginner :)))
Cheers
To insert one empty row between each unique value try this:
Option Explicit
Public Sub addspace()
Dim i As Long
Application.ScreenUpdating = False
With Worksheets("sheet3")
For i = 5000 To 2 Step -1
While .Range("A" & i - 1) = .Range("A" & i)
i = i - 1
Wend
.Rows(i).Insert Shift:=xlDown
Next
End With
Application.ScreenUpdating = True
End Sub
It starts from the end row and moves up, skipping duplicates
The Range("space_1(n)") is invalid. Arg of range object should be a column name like "A1", you can use Range("A" & n).EntireRow.Insert in your code. But I recommend my code.
Please try,
Sub addspace()
Dim n As Integer
For n = 1 To 5000
If Worksheets("sheet3").Cells(n, 1).Value <> Worksheets("sheet3").Cells(n + 1, 1).Value Then
Worksheets("sheet3").Cells(n + 1, 1).EntireRow.Insert
n = n + 1
End If
Next
End Sub
The code I have once worked to add/delete groups of rows (requirements). I needed to modify the code so that if the 1st row of the group met certain criteria (i.e, the requirement was not one we wanted to consider), (1) we would not count it and (2), we would hide the group (current and subsequent 2 rows). This all works fine.
The problem is that now that I incorporated these changes, I get an error in another section of the code and for the life of me I cannot figure out why. I have stepped through this and am extremely frustrated. I am reaching out for help, and am hoping someone can see my error(!)
We calculate the start and finish row numbers within a grouping, and store these calculations in Arrays called "Start" and "Finish." I use the ReDim statement to initialize my arrays, because I thought that could be part of the problem, but no.
Any insight as to why my "subscripts are out of range" would be appreciated. I have traced through the logic, investigated this error, and read about the syntax/usage of VBA arrays. I don't know what else to do. Thanks in advance. Here are the relevant lines:
Sub Button1_Click()
Cells.Select
Selection.ClearOutline
If Cells.EntireRow.Hidden Then Cells.EntireRow.Hidden = False
Dim Start() As Integer
Dim Finish() As Integer
Dim p As Integer, q As Integer
ReDim Start(0, 50)
ReDim Finish(0, 50)
The following is embedded in logic that loops through all the rows in the spreadsheet:
i = 1
For Row = 4 To Cells(1, 6).Value - 1
If Begin Then
If Cells(Row, 3).Interior.ColorIndex = 44 Then
Start(i) = Row + 1
j = Cells(Row, 2).Value
Begin = False
End If
Else
If Cells(Row, 2).Value = j + 1 Or Cells(Row, 2).Interior.ColorIndex = 37 Then
Finish(i) = Row - 1
Begin = True
i = i + 1
Row = Row - 1
End If
End If
Next
The block I changed is as follows (code I added is last block where I attempt to hide rows). It precedes the previous. I am wondering how my change could have affect the above(?!)
If Cells(Row, 5).Value = "Requirement" Then
Range(Cells(Row, 4), Cells(Row, 4)).Interior.ColorIndex = 40
Rows(Row).Font.Bold = True
Rows(Row).Font.Italic = False
Rows(Row).Font.ColorIndex = 1 'Black
If Cells(Row - 3, 4).Value = "" Then 'this is requirement #1
Cells(Row, 4).Value = 1
Else
Cells(Row, 4).Value = Cells(Row - 3, 4).Value + 1
End If
p = Row
q = p + 2
Rows(p & ":" & q).Select
If Cells(p, 19).Value = "4" Then
Selection.EntireRow.Hidden = True
Else
Selection.EntireRow.Hidden = False
End If
Redim Start(0,50) makes the array dimensions 0 to 0, 0 to 50 i.e. a 2d array.
This means that when you call the array you need to provide parameters for both dimensions I.E: Start(0,i) or Finish(0,i). Calling Start(i) will result in the error you mentioned.
The easiest way to get rid of the error is to change your Redim lines to
ReDim Start(50)
ReDim Finish(50)
which is what I assume you meant to do in the first place.
Note: Based upon the format you used, you may have been meaning to do Start(0 to 50) and Finish(0 to 50) initially. The comma in the dimensioning indicates another dimension instead of a separation between lower and upper bounds.
I haven't seen this addressed yet, but I think that might be because I don't know how to phrase my problem concisely. Here's an example of what I'd like to try and do:
Given a column which holds state initials check output sheet if that state has been found before. If it hasn't then populate a new cell with that state's initials and initialize the count (number of times state has been found) to one. If the state's initials are found in a cell within the output sheet then increment the count by one.
With this, if we have a 50,000 (or however many) lined excel sheet that has states in random order (states may or may not be repeated) we will be able to create a clean table which outputs which states are in the raw data sheet and how many times they appeared. Another way to think about this is coding a pivot table, but with less information.
There's a couple of ways that I've thought about how to complete this, I personally think none of these are very good ideas but we'll see.
Algorithm 1, all 50 states:
Create 50 string variables for each state, create 50 long variables for the counts
Loop through raw data sheet, if specific state found then increment appropriate count (this would require 50 if-else statements)
Output results
Overall..... terrible idea
Algorithm 2, flip-flop:
Don't create any variables
If a state is found in raw data sheet , look in output sheet to check if state has been found before
If state has been found before, increment cell adjacent by one
If state has not been found before, change next available blank cell to state initials and initialize cell adjacent to one
Go back to raw data sheet
Overall..... this could work, but I feel as if it would take forever, even with raw data sheets that aren't very big but it has the benefit of not wasting memory like the 50 states algorithm and less lines of code
On a side note, is it possible to access a workbook's (or worksheet's) cells without activating that workbook? I ask because it would make the second algorithm run much quicker.
Thank you,
Jesse Smothermon
A couple of point that will speed up your code:
You don't need to active workbooks, worksheets or ranges to access them
eg
DIM wb as workbook
DIM ws as worksheet
DIM rng as range
Set wb = Workbooks.OpenText(Filename:=filePath, Tab:=True) ' or Workbooks("BookName")
Set ws = wb.Sheets("SheetName")
Set rng = ws.UsedRange ' or ws.[A1:B2], or many other ways of specifying a range
You can now refer to the workbook/sheet/range like
rng.copy
for each cl in rng.cells
etc
Looping through cells is very slow. Much faster to copy the data to a variant array first, then loop through the array. Also, when creating a large amount of data on a sheet, better to create it in a variant array first then copy it to the sheet in one go.
DIM v As Variant
v = rng
eg if rng refers to a range 10 rows by 5 columns, v becomes an array of dim 1 to 10, 1 to 5. The 5 minutes you mention would probably be reduced to seconds at most
Sub CountStates()
Dim shtRaw As Excel.Worksheet
Dim r As Long, nr As Long
Dim dict As Object
Dim vals, t, k
Set dict = CreateObject("scripting.dictionary")
Set shtRaw = ThisWorkbook.Sheets("Raw")
vals = Range(shtRaw.Range("C2"), _
shtRaw.Cells(shtRaw.Rows.Count, "C").End(xlUp)).Value
nr = UBound(vals, 1)
For r = 1 To nr
t = Trim(vals(r, 1))
If Len(t) = 0 Then t = "Empty"
dict(t) = dict(t) + 1
Next r
For Each k In dict.keys
Debug.Print k, dict(k)
Next k
End Sub
I implemented my second algorithm to see how it would work. The code is below, I did leave out little details in the actual problem to try and be more clear and get to the core problem, sorry about that. With the code below I've added the other "parts".
Code:
' this number refers to the raw data sheet that has just been activated
totalRow = ActiveSheet.Range("A1").End(xlDown).Row
For iRow = 2 To totalRow
' These are specific to the company needs, refers to addresses
If (ActiveSheet.Cells(iRow, 2) = "BA") Then
badAddress = badAddress + 1
ElseIf (ActiveSheet.Cells(iRow, 2) = "C") Then
coverageNoListing = coverageNoListing + 1
ElseIf (ActiveSheet.Cells(iRow, 2) = "L") Then
activeListing = activeListing + 1
ElseIf (ActiveSheet.Cells(iRow, 2) = "NC") Then
noCoverageNoListing = noCoverageNoListing + 1
ElseIf (ActiveSheet.Cells(iRow, 2) = "NL") Then
inactiveListing = inactiveListing + 1
ElseIf (ActiveSheet.Cells(iRow, 2) = "") Then
noHit = noHit + 1
End If
' Algorithm beginning
' If the current cell (in state column) has something in it
If (ActiveSheet.Cells(iRow, 10) <> "") Then
' Save value into a string variable
tempState = ActiveSheet.Cells(iRow, 10)
' If this is also in a billable address make variable true
If (ActiveSheet.Cells(iRow, 2) = "C") Or (ActiveSheet.Cells(iRow, 2) = "L") Or (ActiveSheet.Cells(iRow, 2) = "NL") Then
boolStateBillable = True
End If
' Output sheet
BillableWorkbook.Activate
For tRow = 2 To endOfState
' If the current cell is the state
If (ActiveSheet.Cells(tRow, 9) = tempState) Then
' Get the current hit count of that state
tempStateTotal = ActiveSheet.Cells(tRow, 12)
' Increment the hit count by one
ActiveSheet.Cells(tRow, 12) = tempStateTotal + 1
' If the address was billable then increment billable count
If (boolStateBillable = True) Then
tempStateBillable = ActiveSheet.Cells(tRow, 11)
ActiveSheet.Cells(tRow, 11) = tempStateBillable + 1
End If
Exit For
' If the tempState is unique to the column
ElseIf (tRow = endOfState) Then
' Set state, totalCount
ActiveSheet.Cells(tRow - 1, 9) = tempState
ActiveSheet.Cells(tRow - 1, 12) = 1
' Increment the ending point of the column
endOfState = endOfState + 1
' If it's billable, indicate with number
If (boolStateBillable = True) Then
tempStateBillable = ActiveSheet.Cells(tRow - 1, 11)
ActiveSheet.Cells(tRow - 1, 11) = tempStateBillable + 1
End If
End If
Next
' Activate raw data workbook
TextFileWorkbook.Activate
' reset boolean
boolStateBillable = False
Next
I ran it once and it seems to have worked. The problem is that it took roughly five minutes or so, the original code takes 0.2 (rough guess). I think the only way to make the code perform quicker is to somehow be able to not activate the two workbooks over and over. This means that the answer is not complete but I will edit if I figure out the rest.
Note I will revisit pivot tables to see if I can do everything that I need to in them, as of now it looks like there are a couple of things that I won't be able to change but I'll check
Thank you,
Jesse Smothermon
I kept with the second algorithm. There is the dictionary option that I forgot but I'm still not very comfortable with how it works and I generally don't understand it quite yet. I played with the code for a bit and changed some thing up, it now works faster.
Code:
' In output workbook (separate sheet)
Sheets.Add.Name = "Temp_Text_File"
' Opens up raw data workbook (originally text file
Application.DisplayAlerts = False
Workbooks.OpenText Filename:=filePath, Tab:=True
Application.DisplayAlerts = True
Set TextFileWorkbook = ActiveWorkbook
totalRow = ActiveSheet.Range("A1").End(xlDown).Row
' Copy all contents of raw data workbook
Cells.Select
Selection.Copy
BillableWorkbook.Activate
' Paste raw data into "Temp_Text_File" sheet
Range("A1").Select
ActiveSheet.Paste
ActiveWorkbook.Sheets("Billable_PDF").Select
' Populate long variables
For iRow = 2 To totalRow
If (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "BA") Then
badAddress = badAddress + 1
ElseIf (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "C") Then
coverageNoListing = coverageNoListing + 1
ElseIf (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "L") Then
activeListing = activeListing + 1
ElseIf (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "NC") Then
noCoverageNoListing = noCoverageNoListing + 1
ElseIf (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "NL") Then
inactiveListing = inactiveListing + 1
ElseIf (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "") Then
noHit = noHit + 1
End If
If (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 10) <> "") Then
tempState = ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 10)
If (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "C") Or (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "L") Or (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "NL") Then
boolStateBillable = True
End If
'BillableWorkbook.Activate
For tRow = 2 To endOfState
If (ActiveSheet.Cells(tRow, 9) = tempState) Then
tempStateTotal = ActiveSheet.Cells(tRow, 12)
ActiveSheet.Cells(tRow, 12) = tempStateTotal + 1
If (boolStateBillable = True) Then
tempStateBillable = ActiveSheet.Cells(tRow, 11)
ActiveSheet.Cells(tRow, 11) = tempStateBillable + 1
End If
Exit For
ElseIf (tRow = endOfState) Then
ActiveSheet.Cells(tRow, 9) = tempState
ActiveSheet.Cells(tRow, 12) = 1
endOfState = endOfState + 1
If (boolStateBillable = True) Then
tempStateBillable = ActiveSheet.Cells(tRow, 11)
ActiveSheet.Cells(tRow, 11) = tempStateBillable + 1
End If
End If
Next
'stateOneTotal = stateOneTotal + 1
'If (ActiveSheet.Cells(iRow, 2) = "C") Or (ActiveSheet.Cells(iRow, 2) = "L") Or (ActiveSheet.Cells(iRow, 2) = "NL") Then
' stateOneBillable = stateOneBillable + 1
'End If
'ElseIf (ActiveSheet.Cells(iRow, 10) = "FL") Then
'stateTwoTotal = stateTwoTotal + 1
'If (ActiveSheet.Cells(iRow, 2) = "C") Or (ActiveSheet.Cells(iRow, 2) = "L") Or (ActiveSheet.Cells(iRow, 2) = "NL") Then
' stateTwoBillable = stateTwoBillable + 1
'End If
End If
'TextFileWorkbook.Activate
If (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "C") Or (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "L") Or (ActiveWorkbook.Sheets("Temp_Text_File").Cells(iRow, 2) = "NL") Then
billableCount = billableCount + 1
End If
boolStateBillable = False
Next
' Close raw data workbook and raw data worksheet
Application.DisplayAlerts = False
TextFileWorkbook.Close
ActiveWorkbook.Sheets("Temp_Text_File").Delete
Application.DisplayAlerts = True
Thank you for the comments and suggestions. It is very much appreciated as always.
Jesse Smothermon