I'm trying to write a macro that does the following:
Loop through each row in table1 starting with 1 to 50
Loop through each column of the respective row starting with 2 to 100
Concatenate for each row in column 1 all the single fields in column 2 to 100 with a "|" inbetween.
See my code below. I get an error for .Range.Cells(lRow, 1) = .Range.Cells(lRow, 1) & "|" & .Range.Cells(lRow, lCol)
Option Explicit
Sub horizontal_loop()
Dim lRow, lCol As Long
With Worksheets("table1")
For lRow = 1 To 50
For lCol = 2 To 100
.Range.Cells(lRow, 1) = .Range.Cells(lRow, 1) & "|" & .Range.Cells(lRow, lCol)
Next lCol
Next lRow
End With
End Sub
There is no need to use Range if you are using Cells.
.Cells(lRow, 1) = .Cells(lRow, 1) & "|" & .Cells(lRow, lCol)
Alternatively with single loop
Sub horizontal_loop()
Const STARTROW = 1
Const ENDROW = 50
Const STARTCOL = 2
Const ENDCOL = 100
Dim lRow As Long, ar, wsf As WorksheetFunction
Set wsf = WorksheetFunction
With Worksheets("table1")
For lRow = STARTROW To ENDROW
ar = .Cells(lRow, STARTCOL).Resize(, ENDCOL - STARTCOL + 1)
ar = wsf.Transpose(wsf.Transpose(ar))
.Cells(lRow, 1) = Join(ar, "|")
Next lRow
End With
End Sub
Related
I am stuck in my vba code and seems I setup a loop wrong. Really appreciate for some advices! Thank you very much!!
Sub code()
Dim lastRow As Long
Dim k As Integer
Dim rowPtr As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For rowPtr = 2 To lastRow
If Range("A" & rowPtr + 1) <> Range("A" & rowPtr) Then
k = 1
Range("B" & rowPtr) = k
Else
If Range("A" & rowPtr + 1) = Range("A" & rowPtr) Then
Range("B" & rowPtr) = k
End If
k = k + 1
End If
Next
End Sub
Above is my code and now my VBA result is like this:
screenshot
Column C is my ideal result of the code
Rank Reps (Repeating Values)
Adjust the values in the constants section.
Note that Range("A" & rowPtr) is the same as Cells(rowPtr, "A") or Cells(rowPtr, 1), and Range("A" & Rows.Count) is the same as Cells(Rows.Count, "A") or Cells(Rows.Count, 1).
Option Explicit
Sub rankReps()
Const FirstRow As Long = 2
Const sCol As String = "A"
Const dCol As String = "B"
Dim cOffset As Long: cOffset = Columns(dCol).Column - Columns(sCol).Column
Dim LastRow As Long: LastRow = Range(sCol & Rows.Count).End(xlUp).Row
If LastRow < FirstRow Then
MsgBox "No data", vbCritical, "No Data"
Exit Sub
End If
' Write first.
Range(sCol & FirstRow).Offset(, cOffset).Value = 1
' Write remainder.
If LastRow > FirstRow Then
Dim cCell As Range ' Current Cell
Dim r As Long ' Row Counter
Dim rk As Long: rk = 1 ' Rank Counter
For r = FirstRow + 1 To LastRow ' +1: the first is already written
Set cCell = Range(sCol & r)
If cCell.Value = cCell.Offset(-1).Value Then
rk = rk + 1
Else
rk = 1
End If
cCell.Offset(, cOffset).Value = rk
Next r
End If
End Sub
Public Sub UpdateRankings(ByVal ws As Worksheet)
' Adjust as necessary.
Const firstRow As Long = 3
Const colGroupId As Long = 1
Const colRanking As Long = 6
Dim row As Long
With ws
' First value defaults to 1.
row = firstRow
.Cells(row, colRanking).Value = 1
' Remaining rows.
row = row + 1
Do While .Cells(row, colGroupId).Value <> ""
' If group id is the same as the previous row, increment rank.
If .Cells(row, colGroupId).Value = .Cells(row - 1, colGroupId).Value Then
.Cells(row, colRanking).Value = .Cells(row - 1, colRanking).Value + 1
' If group id has changed, reset rank to 1.
Else
.Cells(row, colRanking).Value = 1
End If
' Next row.
row = row + 1
Loop
End With
End Sub
Please, try the next way:
Sub Countcode()
Dim lastRow As Long, k As Long, rowPtr As Long
lastRow = cells(rows.count, 1).End(xlUp).row
k = 1
For rowPtr = 2 To lastRow
If Range("A" & rowPtr) = Range("A" & rowPtr + 1) Then
Range("B" & rowPtr) = k: k = k + 1
Else
If Range("A" & rowPtr) = Range("A" & rowPtr - 1) Then
Range("B" & rowPtr) = k: k=1
Else
k = 1
Range("B" & rowPtr) = k
End If
End If
Next
End Sub
One approach is:
Sub numberIt2()
Dim cl As Range, equal As Integer ' equal initial value is 0
Set cl = Range("A1")
Do While cl <> ""
cl.Offset(0, 1) = equal + 1
Set cl = cl.Offset(1)
equal = IIf(cl = cl.Offset(-1), equal + 1, 0)
Loop
End Sub
i would help me about my code it compares from sheet1 two columns a,b and the duplicated transfer to sheet2 the column c
Sub COPY1()
Dim i
Dim LastRow As Long
LastRow = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Sheets("sheet1").Cells(i, "A").Value = Sheets("sheet1").Cells(i, "B").Value Then
Count = Application.WorksheetFunction.CountIf(Range("B1:B" & i), Sheets("sheet1").Cells(i, "A"))
If Count > 1 Then
Sheets("sheet1").Cells(i, "A").COPY Destination:=Sheets("sheet2").Range("B" &
Rows.Count).End(xlUp).Offset(1)
End If
End If
Next i
End Sub
Give this a try:
Sub COPY1()
Dim i As Long
Dim LastRow As Long
With Sheets("sheet1")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
v = .Cells(i, "A").Value
For j = 2 To LastRow
If v = .Cells(j, "B").Value Then
.Cells(i, "A").Copy Destination:=Sheets("sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1)
End If
Next j
Next i
End With
End Sub
I have a table which contains merged cells both column and rows as shown in attached picture. I want to unmerge "Only" rows while leaving columns merged. Consider the following snippet of table. In the image attached "Contract
For y = 1 To lRow
p = 1
c = y
d = 1
z = lRow + y
t = Cells(y, 1).Value
For x = 1 To t
Cells(z, p).Value = Cells(c, d).Value
Cells(c, d).Select
' Debug.Print
Selection.End(xlToRight).Select
c = ActiveCell.Row
d = ActiveCell.Column
p = p + 1
Next
Next
Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
With c.MergeArea.Rows
.UnMerge
' .Formula = c.Formula
End With
'
'startcolumn = ActiveCell.Column
'endcolumn = Selection.Columns.Count + startcolumn - 1
'startrow = ActiveCell.Row
'endrow = Selection.Rows.Count + startrow - 1
End If
Next
End Sub
Based on your snapshot of requirements , I have wrote a very simple code which shall appear to be crude but I have kept it this way so that you can adjust its various elements as per your actual data. Sample data taken by me and results obtained are shown in the snapshot pasted below, which is followed by code.
Sub Merge_unmerge()
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim LastRow As Long
Dim LastCol As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
With ws
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Set rng = ws.Range("A1:D" & LastRow)
For Each cell In rng
cell.UnMerge
Next cell
For i = 2 To LastRow
If Range("A" & i) = "" Then
Range("A" & i).Value = Range("A" & i - 1).Value
End If
Next i
For i = 2 To LastRow
If Range("D" & i) = "" Then
Range("D" & i).Value = Range("D" & i - 1).Value
End If
Next i
For i = 1 To LastRow Step 2
Range("B" & i & ":C" & i).Merge
Range("B" & i & ":C" & i).HorizontalAlignment = xlCenter
Next i
End Sub
Never mind. I solved for the issue at hand. Posting if it helps others.
Sub ColorMergedCells()
Dim c As Range
Dim startcolumn, endcolumn, startrow, endrow As Long
For Each c In ActiveSheet.UsedRange
If c.MergeCells And c.MergeArea.Rows.Count >= 2 Then
c.Interior.ColorIndex = 28
startcolumn = c.Column
endcolumn = c.MergeArea.Columns.Count + startcolumn - 1
startrow = c.Row
endrow = c.MergeArea.Rows.Count + startrow - 1
With c.MergeArea.Rows
.UnMerge
.Formula = c.Formula
End With
For J = startrow To endrow
Application.DisplayAlerts = False
Range(Cells(J, startcolumn), Cells(J, endcolumn)).Merge
Application.DisplayAlerts = True
Next
End If
Next
End Sub
I want to cut the cells present from the cells in E1:G1 and add it to D2 and copy the cells in range present in A1:C1 to the next row,
and do that to next rows and so on in which they have content from the columns E to G.
I've already tried to use the "Data - Text to Columns" in Excel but I can't use that in order to copy to rows...
What I'm trying to obtain is in this format, but I'm having a hard time finding VBA code in order to do this.
You could try:
Option Explicit
Sub test()
Dim LastRow As Long, LastColumn As Long, i As Long, y As Long
Dim Avalue As String, BValue As String, Cvalue As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 1 Step -1
Avalue = .Range("A" & i).Value
BValue = .Range("B" & i).Value
Cvalue = .Range("C" & i).Value
LastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
If LastColumn > 4 Then
For y = LastColumn To 5 Step -1
.Rows(i + 1).EntireRow.Insert
.Cells(i + 1, 1).Value = Avalue
.Cells(i + 1, 2).Value = BValue
.Cells(i + 1, 3).Value = Cvalue
.Cells(i, y).Cut .Cells(i + 1, 4)
Next y
End If
Next i
End With
End Sub
Array Version
Option Explicit
Sub test()
Dim LastRow As Long, LastColumn As Long, i As Long, y As Long
Dim Avalue As String, BValue As String, Cvalue As String
Dim ABCvalues As Variant
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 1 Step -1
ABCvalues = .Range("A" & i & ":C" & i).Value
LastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
If LastColumn > 4 Then
For y = LastColumn To 5 Step -1
.Rows(i + 1).EntireRow.Insert
.Range("A" & i + 1 & ":C" & i + 1).Value = ABCvalues
.Cells(i, y).Cut .Cells(i + 1, 4)
Next y
End If
Next i
End With
End Sub
I am trying to create a code in Excel VBA, to locate the beginning (Cell Address) and the end (Cell Address) of coloured rows in a table. The table is a timeline(Horizontal axis- Dates, Vertical axis - General Text). The coloured rows all do not start in the first column, but start in different columns.
Any help?
How's this?
Sub findColoredRows()
Dim startCol As Integer, endCol As Integer, o As Integer
Dim ws As Worksheet
Dim i As Integer, k As Integer
Dim startRow As Long, endRow As Long
Dim cellColor As String, noColor As String
Dim cel As Range
noColor = -4142 ' this is the color index of NO coloring
k = 3
Set ws = ActiveSheet
With ws
startRow = .Cells(1, 3).End(xlDown).Row
startCol = .Cells(1, 3).Column
Do While startRow > 100 ' I assume your table starts before row 100. So, if there's no data before row 100, check next column
k = k + 1
startRow = .Cells(1, k).End(xlDown).Row
startCol = k
Loop
'Now, we have our starting row - get end row.
endRow = .Cells(startRow, k).End(xlDown).Row
endCol = .Cells(startRow, startCol).End(xlToRight).Column
Debug.Print "Start row: " & startRow & ", start column: " & startCol
' How many non colored cells is there in our range?
Dim noColorCells As Integer
For Each cel In .Range(.Cells(startRow, startCol), .Cells(endRow, endCol))
If cel.Interior.ColorIndex = noColor Then
noColorCells = noColorCells + 1
End If
Next cel
Debug.Print "There are " & noColorCells & " non colored cells."
.Cells(startRow - 1, endCol + 2).Value = "Start Date"
.Cells(startRow - 1, endCol + 3).Value = "End Date"
'reDim the array to fit the colored cells
ReDim tDates(1 To noColorCells + 1)
i = 1 'index starts at 1, so set this to 1
For k = startRow To endRow
For o = startCol To endCol
If .Cells(k, o).Interior.ColorIndex = noColor And .Cells(k, endCol + 2) = "" Then
.Cells(k, endCol + 2).Value = .Cells(k, o).Value
ElseIf .Cells(k, o).Interior.ColorIndex = noColor And .Cells(k, endCol + 2) Then
i = i + i
.Cells(k, endCol + 3).Value = .Cells(k, o).Value
End If
' i = i + 1
Next o
i = i + 1
Next k
End With
MsgBox ("Done!")
End Sub
This sub will find the addresses of any colored cells. If you can explain more what you mean by "locate the beginning and the end of coloured rows in a table." I can tweak this. Can you post an image of a sample table maybe?
Edit: Per discussion below, try this in case there's not always data in the table, but you want the columns of the colored cells:
Sub findColoredBGCells()
Dim startRow As Integer, endRow As Integer, i As Integer, k As Integer, startCol As Integer, endCol As Integer
Dim cellColor As String, noColor As String
Dim ws As Worksheet
Set ws = ActiveSheet
noColor = -4142
With ws
'Get the starting row
startRow = .Cells(1, 1).End(xlDown).Row
endRow = .Cells(startRow, 1).End(xlDown).Row
' Since we know where the names start and end (less ONE for the "Names" part), let's count how many names we have
Dim noNames As Integer
noNames = endRow - startRow
If Not IsEmpty(.Cells(1, 1)) Then ' Get the first used column with data
startCol = 1
ElseIf IsEmpty(.Cells(1, 1)) Then
startCol = .Cells(1, 1).End(xlToRight).Column
End If
endCol = .Cells(1, startCol).End(xlToRight).Column
'Now we have our range, let's use it to loop for blank cells, and add those to an array
Dim coloredCells() As Variant
ReDim coloredCells(1 To noNames, 2)
Dim rng As Range, cel As Range
Set rng = .Range(.Cells(startRow, startCol), .Cells(endRow, endCol))
'rng.Select
'Now, count how many cells are not blank background
Dim cnt As Integer, celRow As Integer, lastCelRow As Integer
i = 1
lastCelRow = 2
For Each cel In rng
cel.Select
celRow = cel.Row
If cel.Row <> lastCelRow Then 'This is so we can change the first dimension in the array
k = k + 1
coloredCells(k, 0) = .Cells(cel.Row, 1).Value
i = 1
' i = i + 1
End If
If cel.Interior.ColorIndex <> noColor Then
cnt = cnt + 1
If i > 2 Then i = 2 'Since it's only two dimensions we need, only go up to '1'
' ReDim Preserve coloredCells(noNames, i) 'resize the array to hold the new column
coloredCells(k, i) = .Cells(1, cel.Column).Value
i = i + 1
End If
lastCelRow = celRow
Next cel
For k = 1 To UBound(coloredCells)
Debug.Print coloredCells(k, 0) & " Start Date: " & coloredCells(k, 1) & ", end date: " & coloredCells(k, 2) & "."
.Cells(2 + k, 2).Value = coloredCells(k, 1)
.Cells(2 + k, 3).Value = coloredCells(k, 2)
Next k
End With
MsgBox ("Done!")
End Sub