Forgive me, as this may be very simple. I am trying to create a VBA macro that quickly gets statistics from raw data and puts them in a table. The raw data comes in this format:
(They will not always be in groups of three)
How would I get the range for all of a category, and then use that same range for Columns B and C to get the statistics I need?
The below code get you the row numbers of each category and assumes there is no break in content on column B, your question was to get the content of columns C:D by category, having these row values will enable you to code to get the content of C:D.
Public Sub Sample()
Dim WkSht As Worksheet
Dim StrCategory As String
Dim LngRow As Long
Dim LngRowStart As Long
Set WkSht = ThisWorkbook.Worksheets("RawData")
'Take note of the category we are one
StrCategory = WkSht.Range("A" & 2).Value
'Take not of the row the category started on
LngRowStart = 2
'Look to the next row
LngRow = 3
'Loop through the data until column B has no value, signifying the end of the dataset
Do Until WkSht.Range("B" & LngRow) = ""
'Go to the next row until we are given a new category or make it to the end of the dataset
Do Until (WkSht.Range("A" & LngRow) <> "") Or (WkSht.Range("B" & LngRow) = "")
LngRow = LngRow + 1
Loop
'Talk in the immediate pane
Debug.Print StrCategory & " is on rows " & LngRowStart & " to " & LngRow - 1
'Get the next values
StrCategory = WkSht.Range("A" & LngRow)
LngRowStart = LngRow
'Move on
LngRow = LngRow + 1
Loop
Set WkSht = Nothing
End Sub
Below is the input data I gave it: -
Below is the output from the code: -
You could use some If statements and pull this all into an array, but it seems more direct to just fill in the blanks
Sub FillColA()
Dim LastRow As Long
LastRow = Application.WorksheetFunction.CountA(Range("B:B"))
Range("A2:A" & LastRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub
Related
I wanted to convert below formula to VBA code.
=C1&"`"&K1&"`"&L1&"`"&J1
=VLOOKUP(M1,Data!$A:$J,9,)
=SUMPRODUCT(SUMIF(B1:B,B1,G1:G))
Currently i have enter this formula in 1st row and than copying this formula till the last row used which is taking lot time to apply formula because it has more than million row.
LR1 = Sheets("CRIMS").UsedRange.Rows.Count
Sheets("CRIMS").Range("M1:P1").AutoFill Destination:=Sheets("CRIMS").Range("M1:P" & LR1)
is there any way to convert this formula into VBA code?
For first formula the easiest way would be:
Range("M" & i).FormulaR1C1 = "=RC[-10]&""`""&K&""`""&L&""`""&J"
But for vlookup I prefer dictionaries/collections! It is much much faster.
If You have source data in Data sheet and You want to put that to CRIMS sheet to column M:
Sub vlookup()
Dim names As Range, values As Range
Dim lookupNames As Range, lookupValues As Range
Dim vlookupCol As Object
Dim lastRow As Long
Dim lastRow2 As Long
Dim objekt as Object
With Sheets("Data")
lastRow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).row
Set names = Sheets("Data").Range("A1:A" & lastRow)
Set values = Sheets("Data").Range("I1:A" & lastRow)
End With
Set objekt = BuildLookupCollection(names, values)
With Sheets("CRIMS")
lastRow2 = 1000000
Set lookupNames = .Range("M1:M" & lastRow)
Set lookupValues = .Range("N1:N" & lastRow)
End With
VLookupValues lookupNames, lookupValues, objekt
Set objekt = Nothing
End Sub
Function BuildLookupCollection(categories As Range, values As Range)
Dim vlookupCol As Object, i As Long
Set vlookupCol = CreateObject("Scripting.Dictionary")
On Error Resume Next
For i = 1 To categories.Rows.Count
Call vlookupCol.Add(CStr(categories(i)), values(i))
Next i
On Error GoTo 0
Set BuildLookupCollection = vlookupCol
End Function
Sub VLookupValues(lookupCategory As Range, lookupValues As Range, vlookupCol As Object)
Dim i As Long, resArr() As Variant
ReDim resArr(lookupCategory.Rows.Count, 1)
For i = 1 To lookupCategory.Rows.Count
resArr(i - 1, 0) = vlookupCol.Item(CStr(lookupCategory(i)))
Next i
lookupValues = resArr
End Sub
Quotation Marks need to be doubled in VBA
Try this:
For i = 1 To LR1
Range("M" & i).Formula = "=C" & i & "&""`""&K" & i & "&""`""&L" & i & "&""`""&J" & i
Range("N" & i).Formula = "=VLOOKUP(M" & i & ",Data!$A:$J,9,)"
Next i
(replace column letters with actual target column)
As mentioned in the comments Looping in this case is highly inefficient.
Use this Code to insert the formulas all at once. It still takes some time for 1 Milion rows though.
Range("M1:M" & LR1).Formula = "=C:C & ""`"" & K:K & ""`"" & L:L & ""`"" & J:J"
Range("N1:N" & LR1).Formula = "=VLOOKUP(M:M,Data!$A:$J,9,)"
I have working code that checks for a criteria in each row, and if met, copies that whole row of data over to a different workbook. But! I need to be able to add text to the last column of the copied data (Column S) that essentially labels what criteria was met that made the code copy it over because I will soon be expanding to check for multiple different criteria.
So for every row that meets the criteria and gets copied, I want to add "Criteria1" next to it in column S in the new workbook (it will always be column S that will be the first available column).
I have mangled this code together through inheritance and all of your help, so I don't really even know where to begin.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim CoderBook As Workbook
Dim Referrals As Worksheet
Dim Review As Workbook
Dim Crit As Worksheet
Dim LastRow As Long
Dim NextRow As Long
Dim i As Long
Set CoderBook = Workbooks.Open("Coder Referrals.xlsx")
Set Referrals = CoderBook.Sheets("Sheet1")
Set Review = ThisWorkbook
Set Crit = Review.Sheets("Criteria")
'Search code
LastRow = Crit.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.ScreenUpdating = False
'Loop search code
For i = 2 To LastRow
'Specialized Criteria1 Check
If Crit.Range("F" & i) <> Crit.Range("G" & i) Or _
Crit.Range("I" & i) <> Crit.Range("J" & i) Then
'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
Referrals.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = Crit.Rows(i).Value
End If
Next i
'End loop code
CoderBook.Close SaveChanges:=True
Application.ScreenUpdating = True
End Sub
Split the or into two statements:
For i = 2 To LastRow
j = Referrals.Cells(Rows.Count, 1).End(xlUp).row + 1
'Specialized Criteria1 Check
If Crit.Range("F" & i) <> Crit.Range("G" & i) Then
'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
Referrals.Range("S" & j).Value = "Criteria1"
End If
If Crit.Range("I" & i) <> Crit.Range("J" & i) Then
Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
if Referrals.Range("S" & j).value = vbNullString then
Referrals.Range("S" & j).Value = "Criteria2"
Else
Referrals.Range("S" & j).Value = Referrals.Range("S" & j).Value & ", " & "Criteria2"
End if
Next i
In my problem:
First, I need to find "Unit Name" in Column B.
If it found "Unit Name" it should look for "First Name:" in Column D and copy 5 cell right. ("Obama" in I10)
Paste the name "Obama" to Unit Name sheet. (Paste "Obama" to Sheet "1" A1)
I am new in coding therefore i don't know too much about it. I tried with some codes but it is not efficient.
Here is an image to show my problem.
Sub Test()
Dim i As Integer
Dim m As Integer
Dim n As Integer
Dim z As Integer
For i = 1000 To 1 Step -1
If Range("B" & i).Value = "Unit Name" Then
m = 2
m = i + 1
n = i - 18
If Range("D" & n).Value = "First Name:" Then
m = Range("B" & m).Value + 1
Range("H" & n).Copy
Sheets(m).Range("B7").PasteSpecial xlPasteValues
End If
End If
Next i
End Sub
You don't need all those integer variables, you can use a few Range variables instead:
Sub find_name()
Dim mainWS As Worksheet, altWS As Worksheet
Dim unitCel As Range, fNameCell As Range
Set mainWS = Worksheets("Sheet2") 'CHANGE AS NEEDED
Set altWS = Worksheets("Sheet1")
With mainWS
Set unitCel = .Range("B:B").Find(What:="Unit Name")
If Not unitCel Is Nothing Then
Set fNameCell = .Range("D:D").Find(What:="First Name:").Offset(0, 5)
altWS.Range("A1").Value = fNameCell.Value
End If
End With
End Sub
May need to tweak this, depending on where your data is. I am assuming "Obama" could be any text, that is three columns right of column D, where "First Name:" is found.
Sub Shift_Over5()
Dim i As Long
'Sheet name should be a string
Dim SheetName As String
Dim FirstName As Range
Dim UnitName As Range
'Dim l As Byte --> I changed it to lUnitSheetLastrow, because we need to copy the data from sheet1 to sheet 1,2...
' then you need to check the last row of unit sheet and write data to the last row + 1.
Dim lUnitSheetLastrow As Long
Dim FirstMatch As Variant
Dim Start
Start = VBA.Timer
For i = 1 To 40000 Step 1
'For clear code and easy to follow, you need to mention the sheet you want to interact
'Here i use 'Activesheet', i assume that the current sheet is sheet1
If ActiveSheet.Range("A" & i).Value = "Unit Name" Then
' i think we dont need this code line, because we identified the cell in column B has value is "Unit Name"
'Set UnitName = Range("A:A").Find(what:="Unit Name")
' Here you dont need to use Offset
'SheetName = UnitName.Offset(1, 0).Value
SheetName = ActiveSheet.Range("A" & (i + 1)).Value
' Find "First Name" in 20 rows in column E.
' What happen if i<20, the nextline will show the error, because the minimum row is 1
If i < 40 Then
Set FirstName = ActiveSheet.Range("D1" & ":D" & i).Find(what:="First Name:")
Else
Set FirstName = ActiveSheet.Range("D" & i & ":D" & (i + 40)).Find(what:="First Name")
End If
' make sure the SheetName is not empty and Unit sheet is existing in you workbook then copy the first name to unit sheet
If SheetName <> "" And CheckWorkSheetAvailable(SheetName) Then
' Check the first name is not nothing
If Not FirstName Is Nothing Then
'Check if the cell B7 in unit sheet empty or not
If Worksheets(SheetName).Range("H7").Value = "" Then
'if empty, write to B7
Worksheets(SheetName).Range("H7").Value = FirstName.Offset(1, 0).Value
Else
'else, Find the lastrow in column D of unit sheet
lUnitSheetLastrow = Worksheets(SheetName).Cells(Worksheets(SheetName).Rows.Count, 1).End(xlUp).Row
'Write data to lastrow +1
Worksheets(SheetName).Range("A" & (lUnitSheetLastrow + 1)).Value = FirstName.Offset(, 1).Value
End If
End If
End If
'You forgot to put end if here
End If
Next i
Debug.Print Round(Timer - Start, 3)
End Sub
Function CheckWorkSheetAvailable(SheetName As String) As Boolean
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = SheetName Then
CheckWorkSheetAvailable = True
Exit For
End If
Next
End Function
thank you everyone I found the answer.
I have an Excel file with around 100,000 records. I have 6+ columns, the first five of which are:
Required Format:
So far I have :
Sub Main()
Dim i As Long
Dim j As Long
Dim sameRows As Boolean
sameRows = True
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To 4
If StrComp(Cells(i, j), Cells(i + 1, j), vbTextCompare) Then
sameRows = False
End If
Next j
If sameRows Then
Range(Cells(i, 4), Cells(i + 1, 4)).merge
End If
sameRows = True
Next i
End Sub
I am able to get below by running the macro by changing value in Range from 4 to 1/2/3/4 and running macro four times.
Please help me get the data in required format. I still need to merge the empty fields with the previous non empty field.
Pratik, listen carefully to Jeeped. Working with large data in Excel isn't ideal, and working with raw data in merged cells is staring into the abyss - it's a dark, dark place where Range referencing and things like Offset functions will show you a dimension of despair you never knew existed.
If you have this data in another format, say XML, that you've imported into Excel then use VBA to read the data, query it, etc. in its original format. If it exists in a database, then, again, use VBA to access that database and manipulate the recordsets as you wish. If this is your only source of data, then why not write it into an XML document or into VBA's own data storage options (like Collection or arrays).
If you have to use Excel then don't confuse raw data with data display. Yes, the merged cells might be easier to read for the human eye, but I'd just pose the question: is that your primary objective in conducting the merge?
If you must take that leap into the abyss - and you can see that at least two of us would advise against - then at least speed things up by reading from an array and merging rows at a time:
Sub OpenDoorsToHades()
Dim dataSheet As Worksheet
Dim v As Variant
Dim mergeCells As Range
Dim mergeAreas As Range
Dim i As Long
Dim blankStart As Long
Dim blankEnd As Long
Dim doMerge As Boolean
Dim c As Integer
Set dataSheet = ThisWorkbook.Worksheets("data") 'rename to your sheet
'Read values into array of variants
With dataSheet
v = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Value2
End With
'Check for blanks
For i = 1 To UBound(v, 1)
If IsEmpty(v(i, 1)) Then
If Not doMerge Then
blankStart = i - 1
doMerge = True
End If
Else
If doMerge Then
blankEnd = i - 1
For c = 1 To 4
With dataSheet
Set mergeCells = .Range( _
.Cells(blankStart, c), _
.Cells(blankEnd, c))
If mergeAreas Is Nothing Then
Set mergeAreas = mergeCells
Else
Set mergeAreas = .Range(mergeAreas.Address & _
"," & mergeCells.Address)
End If
End With
Next
mergeAreas.Merge
Set mergeAreas = Nothing
doMerge = False
End If
End If
Next
'Format the sheet
dataSheet.Cells.VerticalAlignment = xlCenter
Application.ScreenUpdating = True
End Sub
How about just populating the empty cells with the values above, so the values on the far right are associated with the same values that would've been in the merged cell. For example, if 19 is in cell A2, you can recreate the table starting in G2 with =IF(A2<>"",A2,G1), and this way all empty cells will be populated with the value above, pairing the values at the far right with the exact same values.
I tackled the same problem myself this week. Ambie's solution seemed overly complex, so I wrote something pretty simple to merge rows:
Sub MergeRows()
Sheets("Sheet1").Select
Dim lngStart As Long
Dim lngEnd As Long
Dim myRow As Long
'Disable popup alerts that appear when merging rows like this
Application.DisplayAlerts = False
lngStart = 2
lngEnd = 2
For myRow = 2 To Range("A" & Rows.Count).End(xlUp).Row 'last row
If Range("A" & (myRow + 1)).value = "" Then
'include row below in next merge
lngEnd = myRow + 1
Else
'merge if 2+ rows are included
If lngEnd - lngStart > 0 Then
Range("A" & lngStart & ":A" & lngEnd).Merge
Range("B" & lngStart & ":B" & lngEnd).Merge
Range("C" & lngStart & ":C" & lngEnd).Merge
Range("D" & lngStart & ":D" & lngEnd).Merge
End If
'reset included rows
lngStart = myRow + 1
lngEnd = myRow + 1
End If
Next myRow
Application.DisplayAlerts = True
End Sub
I have a text string that is using the ^ symbol as a delimiter.
I need to separate the text into new rows rather than new columns.
I need to create new rows to not overwrite the next line of data below it.
Is this possible without using a macro? I'm not against using one, I just wouldn't know where to start to write it.
Below is a pic of some sample data. The top part is how it's listed, and the bottom (in yellow) is how I would like it.
Using Excel 2010 on Windows 7 Pro.
Thanks to those that responded. A friend was able to help by providing the following code:
Sub Breakout()
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
For r = LR To 2 Step -1
Set MyCell = Cells(r, 1)
Arry = Split(MyCell.Value, "^")
For c = 0 To UBound(Arry)
If c > 0 Then MyCell.Offset(c, 0).EntireRow.Insert
MyCell.Offset(c, 0) = Arry(c)
Next c
Next r
End Sub
Could try something like this:
Sub reArrange()
Dim inFirstRng As Range
Dim inRng As Range
Dim inCur As Variant
Dim outFirstRng As Range
Dim outCurRng As Range
Dim ws As Worksheet
'CHANGE ARGUMENT TO YOUR SHEET NAME
Set ws = Worksheets("Sheet2")
With ws
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA INPUT IS IN COLUMN A
Set inFirstRng = .Range("A3")
Set inRng = .Range(inFirstRng, inFirstRng.End(xlDown))
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA OUTPUT IS IN COLUMN A
Set outFirstRng = .Range("A9")
Set outCurRng = outFirstRng
End With
For Each cell In inRng.Cells
inCur = WorksheetFunction.Transpose(Split(cell.Value, "^"))
outCurRng.Resize(UBound(inCur), 1).Value = inCur
With ws
.Range("G" & outCurRng.Row & ":L" & outCurRng.Row).Value = _
.Range("G" & cell.Row & ":L" & cell.Row).Value
End With
Set outCurRng = outCurRng.Offset(UBound(inCur), 0)
Next cell
ws.Range("F" & outFirstRng.Row & ":F" & outCurRng.Row - 1).Value = 1
End Sub