I have managed so far to 6 split cells (wrt the colon sign) in the same column. Now I am trying to standardise it for whenever I'll have additional data above (i.e. if last row = 50, then my first row is 44).
My code is as follows:
Dim fullstring As String, colonposition As Integer, j As Integer
For i=1 to 6
fullstring = Cells(j, 1).Value
colonposition = InStr(fullstring, ":")
Cells(j, 2).Value = Mid(fullstring, colonposition + 2)
Cells(j, 1).Value = Left(fullstring, colonposition - 1)
Next j
I have also tried this (but unsuccessfully)
Dim fullstring As String, colonposition As Integer, j As Integer, LastRow as Long, FirstRow as Long
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
FirstRow = LastRow - 6
For j = FirstRow To EndRow
fullstring = Cells(j, 1).Value
colonposition = InStr(fullstring, ":")
Cells(j, 2).Value = Mid(fullstring, colonposition + 2)
Cells(j, 1).Value = Left(fullstring, colonposition - 1)
Next
Any suggestion as to how to proceed to make VBA select the last row and first row = last row - 6?
Sub test()
Dim rng As Range
Dim rngCell As Range
Dim lCtr As Long
Dim vArr
Set rng = Sheet1.UsedRange.Columns(1)
'/ UnComment the comments if you have to set Row limits e.g 6 from last.
'/ Otherwise this code will work on any range.
'
' If rng.Rows.Count > 7 Then
' Set rng = rng.Offset(rng.Rows.Count - 7).Resize(7)
For Each rngCell In rng.Cells
vArr = Split(rngCell.Value2, ":")
For lCtr = LBound(vArr) To UBound(vArr)
rngCell.Offset(0, lCtr) = vArr(lCtr)
Next
Next
' End If
End Sub
Related
I have been googling a lot and I couldnt make this one work in any way.
I have a table of three columns (Name, Value1, Value2) with lots of names.
I need a vba to list all numbers between value 1&2 including them and their respective names.
For example for row A, 3000, 3003 make rows A, 3000; A, 3001; A, 3002; A, 3003 and then continue on the next name and split that name's range into individual numbers.
Is this even possible?
Thank you so much.
I wrote one based on an array to collect then transfer the values.
Sub expandValues()
Dim i As Long, j As Long, arr As Variant
With Worksheets("sheet5")
.Cells(1, "E").Resize(1, 2) = Array("Name", "Value")
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim arr(.Cells(i, "B").Value2 To .Cells(i, "C").Value2, 1 To 2)
For j = LBound(arr, 1) To UBound(arr, 1)
arr(j, 1) = .Cells(i, "A").Value2
arr(j, 2) = j
Next j
.Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0). _
Resize(UBound(arr, 1) - LBound(arr, 1) + 1, UBound(arr, 2)) = arr
Next i
End With
End Sub
Addendum:
Here is yours with an outer loop to process through the rows.
Sub FillIN()
Dim stri As Long, endi As Long
Dim nm As string, i as long, j as long
with workSheets(1)
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
nm = .Cells(i, "A").Value
strti = .Cells(i, "B").Value
endi = .Cells(i, "C").Value
For j= strti To endi
.Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0) = nm
.Cells(.Rows.Count, "E").End(xlUp).Offset(0, 1) = j
Next j
next i
end with
End Sub
Something like the following?
Option Explicit
Public Sub ListLines()
Dim ws As Worksheet, i As Long, y As Long, rowCounter As Long
Application.ScreenUpdating = False
Set ws = ActiveSheet: rowCounter = 1
With ws
For i = 2 To GetLastRow(ws, 1)
For y = .Cells(i, 2) To .Cells(i, 3)
.Cells(rowCounter, 5) = .Cells(i, 1)
.Cells(rowCounter, 6) = y
rowCounter = rowCounter + 1
Next y
Next i
End With
Application.ScreenUpdating = True
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, ByVal columNum As Long) As Long
With ws
GetLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
End Function
This is what I have so far. And it semi works. I need to make it jump on the next line ( it just repeats the first one forever ) and make it stop when done.
I havent been able to make it add +1 on the row portion of (Row, Column) in starti and endi and Name i after it is done with first row range. Mine also runs indefinitely so I also miss a stop once done.
Sub FillIN()
Dim ws As Worksheet
Dim stri As Long, endi As Long
Dim Name As Variant
Set ws = Sheets(1)
Name = Sheets(1).Cells(2, 1).Value
strti = Sheets(1).Cells(2, 2).Value
endi = Sheets(1).Cells(2, 3).Value
For i = strti To endi
ws.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Value = i
ws.Cells(Rows.Count, 5).End(xlUp).Offset(1, 0).Value = Name
Next i
End Sub
What I'm trying to do is remove any rows where a cell value in a specific column matches what is defined to remove. After that is done re-sequence the value in another column by group.
Using the example below:
I want to look at column B and remove any rows that have a value of A or C. Then I want to basically renumber after the dot (.) in column A to reset itself.
Before Macro Code Fig. 1
After value A and C are removed Fig. 2
Final list after column A is renumbered Fig. 3
I figured out how to remove the rows using this code, but stuck on what to do next:
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long
For RowToTest = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" _
Then _
Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
End Sub
This will be easier to do looping from the top down (using step 1 instead of step -1). I've tried to stay true to your original coding and made this:
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long
Dim startRow As Long
Dim i As Integer
startRow = 2
'Clear the rows that have "A" or "C" in column B
For RowToTest = Cells(Rows.Count, 1).End(xlUp).Row to startRow To Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" _
Then _
Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
'If the left 3 characters of the cell above it are the same,_
'then increment the renumbering scheme
For RowToTest = startRow To Cells(Rows.Count, 1).End(xlUp).Row
If Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), "\")) = Left(Cells(RowToTest, 1).Offset(-1, 0).Value, InStr(1, Cells(RowToTest, 1), "\")) Then
i = i + 1
Cells(RowToTest, 1).Value = Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), ".")) & i
Else
i = 0
Cells(RowToTest, 1).Value = Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), ".")) & i
End If
Next RowToTest
End Sub
EDIT: I've updated it to compare all of the string before the backslash and compare using that.
EDIT++: It has been brought to my attention that when deleting rows it is better to work from the bottom up (step -1) to ensure every row is accounted for. I've re-implemented the original steps in the first code.
Admittedly, this isn't probably the most efficient, but it should work.
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long, i As Long
Application.ScreenUpdating = False
For RowToTest = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" Then Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
Dim totalRows As Long
totalRows = Cells(Rows.Count, 1).End(xlUp).Row
Dim curCelTxt As String, aboveCelTxt As String
For i = totalRows To i Step -1
If i = 1 Then Exit For
curCelTxt = Left(Cells(i, 1), WorksheetFunction.Search("\", Cells(i, 1)))
aboveCelTxt = Left(Cells(i - 1, 1), WorksheetFunction.Search("\", Cells(i - 1, 1)))
If curCelTxt = aboveCelTxt Then
Cells(i, 1).Value = ""
Else
Cells(i, 1).Value = WorksheetFunction.Substitute(Cells(i, 1), Right(Cells(i, 1), Len(Cells(i, 1)) - WorksheetFunction.Search(".", Cells(i, 1))), "0")
End If
Next i
Dim rng As Range, cel As Range
Dim tempLastRow As Long
Set rng = Range("A1:A" & Cells(Rows.Count, 2).End(xlUp).Row)
For Each cel In rng
If cel.Offset(1, 0).Value = "" Then
tempLastRow = cel.End(xlDown).Offset(-1, 0).Row
If tempLastRow = Rows.Count - 1 Then
tempLastRow = Cells(Rows.Count, 2).End(xlUp).Row
cel.AutoFill Destination:=Range(cel, Cells(tempLastRow, 1))
Exit For
Else
cel.AutoFill Destination:=Range(cel, Cells(tempLastRow, 1))
End If
End If
Next cel
Application.ScreenUpdating = True
End Sub
Mainly, I discovered that you can use AutoFill to fix the last number in the string. Meaning if you AutoFill this text, CAT\Definitions.0 down, you get the number updating as you drag/fill.
I wanna write a macro which copy the 1 cells to another sheet if they contain some value.
Table:
Expectation:
So far I tried this but it copy only last cell from sheet1 to first cell in sheet 2
Sub CopyBasedonSheet1()
Dim i As Integer
Dim j As Integer
Sheet1LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row
For j = 1 To Sheet1LastRow
For i = 1 To Sheet2LastRow
If Worksheets("Sheet1").Cells(j, 2).Value = "a" Then
Worksheets("Sheet2").Cells(i, 1).Value = Worksheets("Sheet1").Cells(j, 1).Value
Else
End If
Next i
Next j
End Sub
You should do it with one loop, because when you have a row from the first sheet, there is only 1 place where you want to copy it, not many:
Sub CopyBasedonSheet1()
Dim i As Integer
Dim j As Integer
Sheet1LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
i = 1
For j = 1 To Sheet1LastRow
If Worksheets("Sheet1").Cells(j, 2).Value = "a" Then
Worksheets("Sheet2").Cells(i, 1).Value = Worksheets("Sheet1").Cells(j, 1).Value
Worksheets("Sheet2").Cells(i, 2).Value = Worksheets("Sheet1").Cells(j, 2).Value
i = i + 1
End If
Next j
End Sub
Or you may try a different approach altogether which is faster also...
Sub CopyData()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim x, y()
Dim i As Long, j As Long
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
x = ws1.Range("A1").CurrentRegion.Value
ReDim y(1 To Application.CountIf(ws1.Columns(2), "a"), 1 To 2)
j = 1
For i = 1 To UBound(x, 1)
If x(i, 2) = "a" Then
y(j, 1) = x(i, 1)
y(j, 2) = x(i, 2)
j = j + 1
End If
Next i
ws2.Range("A:B").Clear
ws2.Range("A1").Resize(UBound(y, 1), 2).Value = y
End Sub
How can I generate the Excel as in the image below via a macro?
Briefly I would like to make:
numbers between a1 and b1 print to d column;
numbers between a2 and b2 print to e column;
numbers between a3 and b3 print to f column.
Columns A and B have thousands of values.
As an alternative, here is a formula solution:
=IF(ROW(D1)>INDEX($A:$B,COLUMN(D1)-COLUMN($C1),2)-INDEX($A:$B,COLUMN(D1)-COLUMN($C1),1)+1,"",INDEX($A:$B,COLUMN(D1)-COLUMN($C1),1)+ROW(D1)-1)
Though I realize that a formula solution may not be feasible based on this statement:
Columns A and B have thousands of values.
EDIT: Pure array VBA solution:
Sub tgr()
Dim ws As Worksheet
Dim rData As Range
Dim aData As Variant
Dim aResults() As Variant
Dim lMaxDiff As Long
Dim i As Long, j As Long
Dim rIndex As Long, cIndex As Long
Set ws = ActiveWorkbook.ActiveSheet
Set rData = ws.Range("A1", ws.Cells(Rows.Count, "B").End(xlUp))
lMaxDiff = Evaluate("MAX(" & rData.Columns(2).Address(external:=True) & "-" & rData.Columns(1).Address(external:=True) & ")") + 1
aData = rData.Value2
ReDim aResults(1 To lMaxDiff, 1 To rData.Rows.Count)
For i = LBound(aData, 1) To UBound(aData, 1)
If IsNumeric(aData(i, 1)) And IsNumeric(aData(i, 2)) Then
rIndex = 0
cIndex = cIndex + 1
For j = Int(aData(i, 1)) To Int(aData(i, 2))
rIndex = rIndex + 1
aResults(rIndex, cIndex) = j
Next j
End If
Next i
ws.Range("D1").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub
Only because I like puzzles:
Sub u5758()
Dim x As Long
Dim i As Long
Dim oArr() As Variant
Dim arr() As Long
Dim rng As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet
x = 4
With ws
oArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp)).value
For j = LBound(oArr, 1) To UBound(oArr, 1)
ReDim arr(oArr(j, 1) To oArr(j, 2))
For i = LBound(arr) To UBound(arr)
arr(i) = i
Next i
.Cells(1, x).Resize(UBound(arr) - LBound(arr) + 1).value = Application.Transpose(arr)
x = x + 1
Next j
End With
Application.ScreenUpdating = True
End Sub
I like puzzles too.
Sub from_here_to_there()
Dim rw As Long
With Worksheets("Sheet5") '<~~ set this worksheet properly!
For rw = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If IsNumeric(.Cells(rw, 1)) And IsNumeric(.Cells(rw, 2)) Then
With .Columns(Application.Max(4, .Cells(1, Columns.Count).End(xlToLeft).Column + 1))
.Cells(1, 1) = .Parent.Cells(rw, 1).Value2
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=.Parent.Cells(rw, 2).Value2
End With
End If
Next rw
End With
End Sub
You could use this:
Sub test()
Dim Lastrow As Long
Dim j As Double, i As Double, r As Double
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Change the name of your sheet
Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
j = 4 ' Column D
With ws
For i = 1 To Lastrow ' Start the loop at A1 until the last row in column A
.Cells(1, j) = .Cells(i, 1).Value
r = 1
Do
.Cells(r + 1, j) = .Cells(r, j) + 1
r = r + 1
Loop Until .Cells(r, j) = .Cells(i, 2).Value
j = j + 1
Next i
End With
End Sub
Here's another quick one just for fun:
Sub transposeNfill()
Dim lastRow&, i&, xStart$, xEnd$, xMid$
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow
xStart = Cells(i, 1)
xEnd = Cells(i, 2)
xMid = xEnd - xStart
Cells(1, i + 3).Value = xStart
Cells(1 + xMid, i + 3) = xEnd
Range(Cells(2, i + 3), Cells(xMid, i + 3)).FormulaR1C1 = "=r[-1]c+1"
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Next i
End Sub
I have a small sample example sheet of data, which will be filled with much more data if I can get this process to work.
What I am trying to do is, based upon the number of cells that are filled in each row, insert the same number of blank lines under that same row and copy everything down all columns that are blank. I have attached two screenshots - a before and after of what the start and end look like, as well as the code used for implementing the blank row insert. So far, all it does is add 8 rows consistently, and is using an older version of Excel. I'm trying to translate it into the new VBA format, but I can't seem to get it to work.
Start:
The result I'm trying to achieve:
Code:
Sub IfYes()
Dim Col As Variant
Dim Y As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim C As Long
Dim StartRow As Long
Col = "AS"
Y = "Y"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "Yes" Then
.Cells(R, Col).Offset(1, 0).Resize(8, 1).EntireRow.Insert
.Cells(R, StartRow).Offset(1, 0).Resize(8, 1).Value = .Cells(R, 1).Value
For C = 1 To 8 Step 1
.Cells(R, Y).Offset(C, 0).Value = .Cells(R, Col).Offset(0, C).Value
Next C
.Cells(R, Col) = "Done"
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
I also have another bit of code that I've been trying to use to get this to function properly.
Dim wb1 As Workbook, ws1 As Worksheet
Dim lRow As Long
Dim LastRow As Range
Dim StartRow As Range
Dim i As Long
Set wb1 = Application.Workbooks.Open("Z:\Employee Folders\Jason\crystal spreadsheet - start.xls")
Set ws1 = wb1.Worksheets("AMZStart")
With ws1
For lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 1 Step -1
If Cells(lRow, "B") = "AMZ" Then Rows(lRow).Offset(1, 0).EntireRow.Insert
Next lRow
LastRow = Range("C" & Rows.Count).End(xlUp).Row + 1
StartRow = 1
For i = StartRow To LastRow
If Cells(i, "C") = "" And i > StartRow Then
Cells(i, "C").Formula = "=SUM(C" & StartRow & ":C" & i - 1 & ")"
StartRow = i + 1
End If
Next
End With
End Sub
I find that storing the values in variant arrays can help.
Sub expand_Entries()
Dim v As Long, vAMZs As Variant, vVALs As Variant
Dim rw As Long, c1 As Long, c2 As Long, c As Long, cs As Long
With Worksheets("Sheet2")
c1 = Application.Match("status", .Rows(1), 0)
c2 = .Cells(1, Columns.Count).End(xlToLeft).Column
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
cs = Application.CountA(.Cells(rw, c1 + 1).Resize(1, c2 - c1))
If CBool(cs) Then
vVALs = .Cells(rw, 1).Resize(1, c1 - 1).Value2
With .Cells(rw, c1).Resize(1, cs + 1)
vAMZs = .Cells.Value2
.Offset(0, 1).ClearContents
End With
For c = UBound(vAMZs, 2) To LBound(vAMZs, 2) + 1 Step -1
.Cells(rw + 1, 1).Resize(1, c1 - 1).EntireRow.Insert
.Cells(rw + 1, 1).Resize(1, c1 - 1) = vVALs
.Cells(rw + 1, 8) = vAMZs(1, c)
Next c
End If
Next rw
End With
End Sub
You can use a the CountA Worksheet Function inside your IF block to determine the count of filled cells. Then just replace the 8's with the count of each row.
See code:
If .Cells(R, Col) = "Yes" Then
'get count
Dim iCells As Integer
iCells = WorksheetFunction.CountA(.Range("A" & R & ":R" & R))
.Cells(R, Col).Offset(1, 0).Resize(iCells, 1).EntireRow.Insert
.Cells(R, StartRow).Offset(1, 0).Resize(iCells, 1).Value = .Cells(R, 1).Value
For C = 1 To iCells Step 1
.Cells(R, Y).Offset(C, 0).Value = .Cells(R, Col).Offset(0, C).Value
Next C
.Cells(R, Col) = "Done"
End If