I would like to repeat ID number based on the "number" number. For example:
to
I have tried the following so far..
Sub MySub()
Do While B2 = n
CurrentSheet.Range("a1:c1").EntireRow.Resize(n).Insert
Loop
End Sub
It probably doesn't make much sense, as I am fairly new!
If you wanted to list the data in column D, you could use this
Sub x()
Dim r As Range
For Each r In Range("A2", Range("A" & Rows.Count).End(xlUp)) 'loop through A
Range("D" & Rows.Count).End(xlUp)(2).Resize(r.Offset(, 1).Value).Value = r.Value 'duplicate number of times in B
Next r
End Sub
If you want to insert into your existing data
Sub x()
Dim r As Long
For r = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
If Cells(r, 2) > 1 Then
Cells(r + 1, 1).EntireRow.Resize(Cells(r, 2).Value - 1).Insert shift:=xlDown
Cells(r + 1, 1).Resize(Cells(r, 2).Value - 1) = Cells(r, 1).Value
End If
Next r
End Sub
Related
Following code is suggested by a helpful user, this works well to Calculate "From", "To", "MAX" etc values of a range. But this code gives results in every row of a range. I want to get the results in only first row of each row. Please help with this.
Sub trial()
Dim lastrow As Long
Dim destSht As Worksheet
Dim i As Long, j As Long
Set destSht = Worksheets("Final")
With Worksheets("Source")
lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
For i = 2 To lastrow + 1 'loop whole range (column C)
If .Cells(i, "C") <> "" Then 'If column C is not empty then
For j = i To lastrow + 1 'Loop "group" range to find next empty cell. Start from current loop i to last row and add one row to get to next empty cell.
If .Cells(j, "C") = "" Then 'When next empty cell is found (i.e. end of small group range) then apply formulas
.Cells(i, "E").Value = .Cells(i, "B").Value 'From
.Cells(i, "F").Value = .Cells(j - 1, "B").Value 'To
.Cells(i, "G").Formula = "=MAX(C" & i & ":C" & j - 1 & ")" 'MAX
.Cells(i, "H").Formula = "=MIN(C" & i & ":C" & j - 1 & ")" 'MIN
.Cells(i, "I").Formula = "=AVERAGE(C" & i & ":C" & j - 1 & ")" 'AVG
Exit For
End If
Next j
End If
Next I
End With
End Sub
This Code gives following result
Desired Result
Try changing this line:
If .Cells(i, "C") <> "" Then 'If column C is not empty then
To this line:
If .Cells(i, "C") <> "" AND .Cells(i-1, "C") = "" Then 'If column C is not empty AND the column C above is empty then
I have 3 columns A, B, C and I want to make a column D with values in A, B, C but it should include ">=", "<=" signs as well. The script I am working on does help me loop around columns and copy its data to a new column. Can anyone help me figure out how I can add those special characters at the beginning of the numbers in the cells?
Thanks for any help.
Sub Try()
With ActiveWorkbook.Sheets("Sheet1")
For rw = 1 To .Rows.Count
If (.Rows(rw).Columns("A:A").Value <> "") Then
.Rows(rw).Columns("A:A").Copy .Range("D" & rw)
End If
Next rw
.Columns("A:A").Delete
End With
End Sub
With data in cols A through C, in D1 enter:
=IF(A1<>"",">="&A1,IF(B1<>"","<="&B1,C1))
and copy down:
EDIT#1:
To do this with VBA:
Sub PopulateFormulas()
Dim N As Long, s As String
s = "=IF(A1<>"""","">=""&A1,IF(B1<>"""",""<=""&B1,C1))"
N = Range("A1").CurrentRegion.Rows.Count
Range("D1:D" & N).Formula = s
End Sub
Probably not the most elegant solution (and you probably don't even need VBA for this, a formula would most likely suffice), but this does the trick:
Sub Test()
arr = Array(">=", "<=", "")
With ActiveWorkbook.Sheets("Sheet1")
For cl = 1 To 3
For rw = 2 To .Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
If .Cells(rw, cl).Value <> "" Then
.Cells(rw, 4).Value = arr(cl - 1) & .Cells(rw, cl).Value
End If
Next rw
Next cl
End With
'If you still need to delete those columns at the end-
'ActiveWorkbook.Sheets("Sheet1").Columns("A:C").Delete xlShiftLeft
End Sub
This worked for me:
Sub macro_test()
k = 1
For k = 1 To 3
t = 2
lr = ActiveSheet.Cells(100000, k).End(xlUp).Row
Do Until t > lr
If Cells(t, k).Value = “” Then GoTo continue
If k = 1 Then Cells(t, 4).Value = ">=" & Cells(t, k).Value
If k = 2 Then Cells(t, 4).Value = "<=" & Cells(t, k).Value
If k = 3 Then Cells(t, 4).Value = "" & Cells(t, k).Value
continue:
t = t + 1
Loop
Next
End Sub
try this
Sub main()
Dim iCol As Long, cell As Range, signs As Variant
signs = Array(">=", "<=", "")
For iCol = 1 To 3
For Each cell In Columns(iCol).SpecialCells(xlCellTypeConstants, xlNumbers)
cell.Value = signs(iCol - 1) & cell.Value
Next
Next
End Sub
if your columns A, B and C not empty cells content is not a numeric one only, then you could use:
For Each cell In Columns(iCol).SpecialCells(xlCellTypeConstants)
while if it's some formula, then you could use:
For Each cell In Columns(iCol).SpecialCells(xlCellTypeFormulas)
I'm trying to copy a cell and the adjacent cell in a row and insert it as a new row with all the data to the right of this cell also copied over. My data looks like this after mining.
and im trying to get my data to look like this:
the image above is just one record but essentially its moving all the people and their corresponding position in the original row to a new row. In each row there are about 5 employees and their positions.
thanks
EDIT Attempted code for just 2 cols. 1 position. the idea was to create the empty rows and just copy the rest of the data with auto fill, then work from there
Sub TransposeInsertRows()
Dim rng As Range
Dim i As Long, j As Long, k As Long
Dim x As Long, y As Long
Set rng = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Enter the name col and pos col", Type:=8)
Application.ScreenUpdating = False
x = rng(1, 1).Column + 2
y = rng(1, rng.Columns.Count).Column
For i = rng(rng.Rows.Count, 1).Row To rng(1, 1).Row Step -1
If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then
k = Cells(i, x - 2).End(xlToRight).Column
If k > y Then k = y
For j = k To x + 1 Step -1
Cells(i + 1, 1).EntireRow.Insert
With Cells(i + 1, x - 2)
.Value = .Offset(-1, 0)
.Offset(0, 1) = .Offset(-1, 1)
.Offset(0, 2) = Cells(i, j)
End With
Cells(i, j).ClearContents
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
If there are always 5 people in each row then this should do it:
Sub foo()
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow 'loop through rows
For x = 1 To 10 Step 2 'loop through columns
LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row + 1 'find the next free row on Sheet2
Sheet2.Cells(LastRow2, 1).Value = Sheet1.Cells(i, x).Value 'add Person Name to Sheet2
Sheet2.Cells(LastRow2, 2).Value = Sheet1.Cells(i, x + 1).Value 'add position to Sheet2
Sheet1.Range("K" & i & ":U" & i).Copy Destination:=Sheet2.Cells(LastRow2, 3) 'copy range from K to U to Sheet2
Next x
Next i
End Sub
Sub NewMacro()
Dim endRow As Long
endRow = Sheet1.Range("A999999").End(xlUp).Row
For i = 1 To endRow
If Sheet1.Range("A" & i).Value = Sheet1.Range("F" & i).Value Then
Sheet1.Range("K" & i).Value = "Yes" Else
Sheet1.Range("K" & i).Value = "No"
End If
Next i
End Sub
This will compare column A with column F and displays the result in column K.
What I need is if this value is true, then like the above it should compare column B with column G, column C with column H and so on......and should display the results in next column. Please help.
I think you need a loop on the columns:
Sub NewMacro()
Dim endRow As Long
Dim i As Long
Dim c As Long
With Sheet1
endRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To endRow
For c = 1 To 5
If .Cells(i, c).Value = .Cells(i, c + 5).Value Then
.Cells(i, c + 10).Value = "Yes"
Else
.Cells(i, c + 10).Value = "No"
End If
Next c
Next i
End With
End Sub
This compares column A with F, column B with G, column C with H, column D with I and column E with J. Results are placed in columns K, L, M, N and O respectively.
This is equivalent to using the formula =IF(A1=F1,"Yes","No") in cell K1 and copying it across and down.
And a version which will update columns with "Yes", but stop as soon as it reaches a "No":
Sub NewMacro()
Dim endRow As Long
Dim i As Long
Dim c As Long
With Sheet1
endRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To endRow
For c = 1 To 5
If .Cells(i, c).Value = .Cells(i, c + 5).Value Then
.Cells(i, c + 10).Value = "Yes"
Else
.Cells(i, c + 10).Value = "No"
Exit For
End If
Next c
Next i
End With
End Sub
Example of my dataset:
blank
1
2
blank
3
4
5
blank
6
I want to merge all cells below a blank cell into the blank cell, but stop counting when it reaches the next blank cell.
End result should look like this, with the strings concatenated
12
345
6
I'm currently trying to create an array with 1s and 2s with 2 meaning its a blank cell, then counting the 1s and merging them. I don't know if this will work or if there is an easier way to do this.
This requires you to select the area you want to merge, starting with the first blank cell and ending with the last cell with a value. It will delete entire rows; not sure if that's what you wanted:
Sub MergeConstantsIntoEmpties()
Dim BlankCells As Excel.Range
Dim ConstantCells As Excel.Range
Dim i As Long
Dim MungedContents As String
With Selection
Set BlankCells = .SpecialCells(xlCellTypeBlanks)
Set ConstantCells = .SpecialCells(xlCellTypeConstants)
End With
For i = 1 To BlankCells.Areas.Count
If ConstantCells.Areas(i).Count = 1 Then
MungedContents = ConstantCells.Areas(i).Value
Else
MungedContents = Join(Application.WorksheetFunction.Transpose(ConstantCells.Areas(i).Value))
End If
BlankCells.Areas(i).Value = MungedContents
Next i
ConstantCells.EntireRow.Delete
End Sub
If we start with:
and run this macro:
Sub PileOn()
Dim N As Long, st As String
Dim i As Long, v As Variant
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 1 Step -1
v = Cells(i, 1).Value
If v <> "" Then
st = st & v
Cells(i, 1).Delete shift:=xlUp
Else
Cells(i, 1).Value = st
st = ""
End If
Next i
End Sub
We end up with:
EDIT#1:
To fix the order of the concatenated cells use this instead:
Sub PileOn()
Dim N As Long, st As String
Dim i As Long, v As Variant
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 1 Step -1
v = Cells(i, 1).Value
If v <> "" Then
st = v & st
Cells(i, 1).Delete shift:=xlUp
Else
Cells(i, 1).Value = st
st = ""
End If
Next i
End Sub
Here is my take on it.
Sub JoinBetweenTheLines()
Dim X As Long
X = 1
Do Until X >= Range("A" & Rows.Count).End(xlUp).Row
If Range("A" & X).text = "" Then
Range("A" & X).Delete xlUp
ElseIf Range("A" & X).Offset(1, 0).text = "" Then
X = X + 1
Else
Range("A" & X).Formula = Join(Application.Transpose(Range("A" & X & ":A" & X + 1)), "")
Range("A" & X + 1).Delete xlUp
End If
Loop
End Sub
I normally work backwards also but for this one went forwards.
I had memory processing in mind.
Sub merg()
Dim v As Long, w As Long, vVALs As Variant
With ActiveSheet 'reference the worksheet properly!
With .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
vVALs = .Cells.Value2
For v = LBound(vVALs, 1) To UBound(vVALs, 1)
If vVALs(v, 1) = vbNullString Then
For w = v + 1 To UBound(vVALs, 1)
If vVALs(w, 1) = vbNullString Then Exit For
vVALs(v, 1) = vVALs(v, 1) & vVALs(w, 1)
vVALs(w, 1) = vbNullString
Next w
End If
Next v
.Cells = vVALs
With .SpecialCells(xlCellTypeBlanks)
.Delete Shift:=xlUp
End With
End With
End With
End Sub