VBA For Next Loop through a range - excel

For the first row of my range data, everything works fine. When I execute "Next cell", it moves down to the second row of data, but the first value is from the second column of data.
Example: data is from columns K:N. The first data is in row 2. When it goes to "Next cell", the row changes to three, but cell.value = the value from column L row 3 instead of column K row 3. Is this normal? Shouldn't it start with the left-most column when I move to next C and the row changes? Thanks!
Function Modifer_Analysis()
Dim modRng As Range
Dim cell As Range
Dim i As Integer
Dim col As Integer
Dim rowTrack As Double
Dim modComp As String
Range("K2:N17914").Select
Set modRng = Selection
rowTrack = 2
For Each cell In modRng
If rowTrack = cell.row Then
If i = 0 And IsEmpty(cell.Value) = False Then
modComp = cell.Value
Else
End If
If i = 1 And IsEmpty(cell.Value) = False Then
modComp = modComp & "," & cell.Value
Else
End If
If i = 2 And IsEmpty(cell.Value) = False Then
modComp = modComp & "," & cell.Value
Else
End If
If i = 3 And IsEmpty(cell.Value) = False Then
modComp = modComp & "," & cell.Value
Else
End If
i = i + 1
Else
i = 0
rowTrack = cell.row
modComp = ""
End If
Next cell
End Function

It's not clear exactly what you're trying to achieve, but maybe something more like this would be a good start:
Function Modifer_Analysis()
Dim cell As Range, rw As Range
Dim modComp As String, sep As String
'loop over rows
For Each rw In Range("K2:N17914").Rows 'needs a worksheet qualifier here
modComp = ""
sep = ""
For Each cell In rw.Cells
'loop over cells in row
If Len(cell.Value) > 0 Then
modComp = modComp & sep & cell.Value
sep = ","
End If
Next cell
Next rw
End Function

Related

How to copy the column A to M from a row in sheet1 to sheet2 if it doesn't already exist

I would like to select some rows by putting an X in the column L, then copy selected row (Only column A to M) to the next free row in sheet2.
Free row mean there is nothing in the column A to M since there is content in the next column already filled.
The copy shouldn't erase the content already existing after column M.
The row can't be added if it's already in the sheet2 and to test this, I have an unique ID for the row in column M.
Some of the column of the row that should be copied are sometimes empty.
Part of what I tried :
Sub GAtoList()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim L As Long
A = Worksheets("knxexport").Range("d" & Worksheets("knxexport").Rows.Count)
B = Worksheets("Sheet2").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("knxexport").Range("L1:L" & A)
Application.ScreenUpdating = False
For L = 1 To xRg.Count
If CStr(xRg(L).Value) = "X" Then
xRg(L).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & B + 1)
B = B + 1
Cells(L, B).EntireRow.Interior.ColorIndex = 4
End If
Next
'Erase the X that select the row I want to copy
Worksheets("knxexport").Columns(12).ClearContents
Worksheets("Sheet2").Columns(12).ClearContents
Application.ScreenUpdating = True
End Sub
Column D is never empty so I use it to check the end of the source sheet
knxexport sheet where I take data
sheet2 where I want to copy them
Please, test the next code:
Sub GAtoList()
Dim sh As Worksheet, shDest As Worksheet, lastRL As Long, LastRM As Long
Dim strSearch As String, rngM As Range, arrCopy, cellF As Range, rngL As Range, cellFAddress As String, i As Long, mtch
strSearch = "X"
Set sh = 'Worksheets("knxexport") 'the sheet to copy from
Set shDest = 'Worksheets("Sheet2") 'the sheet to copy to
shDest.Range("M:M").NumberFormat = "#" 'format the M:M column as text
lastRL = sh.Range("L" & sh.rows.count).End(xlUp).row
Set rngL = sh.Range("L2:L" & lastRL) 'the range to search for "X"
Set cellF = rngL.Find(what:=strSearch, After:=sh.Range("L2"), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
If Not cellF Is Nothing Then 'If at least an "X" string has been found:
cellFAddress = cellF.Address 'memorize its (first) address
Do
LastRM = shDest.Range("M" & shDest.rows.count).End(xlUp).row 'last row in M:M
If LastRM > 1 Then 'if there already are IDs:
Set rngM = shDest.Range("M2:M" & LastRM)
mtch = Application.match(sh.cells(cellF.row, "M").Value, rngM, 0)
If IsError(mtch) Then 'no ID found
shDest.Range("A" & LastRM + 1 & ":" & "M" & LastRM + 1).Value = _
sh.Range(sh.Range("A" & cellF.row), sh.Range("M" & cellF.row)).Value
Else
Debug.Print sh.cells(cellF.row, "M").Value & " already existing..." 'warn in case of ID existence...
End If
Else
'copy in the second row
shDest.Range("A2:M2").Value = _
sh.Range(sh.Range("A" & cellF.row), sh.Range("M" & cellF.row)).Value
End If
Set cellF = rngL.FindNext(cellF)
Loop While cellF.Address <> cellFAddress 'exit to avoid restarting loop from the memorized address
Else
MsgBox strSearch & " could not be found in ""L:"" column...": Exit Sub
End If
End Sub

VBA- Cell is a number then copy it

I have in E, F and I columns something written. In E and F its a name and in I its a number. In I column there are some cells with number and rest are blank. When ever its a number, I should copy the names from E1, F1 and copy it to C3 and D3 respectively. I have written a code but its not functioning properly. Could you please help me.
Option Explicit
Sub copy()
Dim cell As Long
Dim nr As Integer
Dim rng As range
Dim i As Long
range("G1:G15").Select
Selection.CurrentRegion.Select
nr = Selection.Rows.Count
For i = 2 To nr
'test if cell is empty
If ActiveCell(i, 7) = "" Then
'write to adjacent cell
ActiveCell = ActiveCell + 1
Else
ActiveCell.Offset(-3, -2).Value.copy ActiveCell.Offset(-3, 0)
End If
Next i
End Sub
Option Explicit
Sub copy()
Dim Row As Long
Dim Col As Long
Row = 2
Col = 9
Do Until Cells(Row, 5).Value = ""
If IsNumeric(Cells(Row, Col)) = True Then
Range("E" & Row & ":F" & Row).copy
Range("C" & Row).PasteSpecial (xlPasteValues)
End If
Row = Row + 1
Loop
Application.CutCopyMode = False
End Sub

Based on color and value fetching-Compiles but no output

I am working on a dynamic worksheet which the total rows and columns of content will be changing.
What I try to do is, making an active cell going through the worksheet. It starts from the very last column that has content (I used UsedRange here), and from the 7st row down to the last row not blank.
When 1) The active cell has a color filling of index 16 or 36; 2) The active cell has no value, the cell will fetch the value storing in the matching row E.
The loop will end when hitting column E (I haven't been able to go that far yet).
I will attach my code below for all possible help, since it complies but does not return any result...Thank you again!
Sub catchCurrentAutomated()
Dim column As Integer
Dim row As Integer
Dim Cell As Range
row = 7
column = ActiveSheet.UsedRange.Columns.Count
Set Cell = ActiveCell
While range("A" & row) <> ""
If Cell.Interior.ColorIndex = 16 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
ElseIf Cell.Interior.ColorIndex = 36 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
End If
row = row + 1
column = column - 1
Wend
End Sub
Something like this should work (untested)
Sub catchCurrentAutomated()
Dim col As Long '<< use Long not Integer
Dim row As Long
Dim c As Range, ws As Worksheet, lr As Long, indx
Set ws = ActiveSheet
col = ws.UsedRange.Columns.Count
lr = ws.Cells(Rows.Count, 1).End(xlUp).row 'last occupied cell in ColA
Do While col > 5
For row = 7 To lr
With ws.Cells(row, col)
indx = .Interior.Color.Index
If (indx = 16 Or indx = 36) And Len(.Value) = 0 Then
.Value = ws.Cells(row, "E").Value
End If
End With
Next row
col = col - 1 'next column to left
Loop
End Sub

Merge cells in column F, G based on a values in Column A

I'm looking for VBA code that looks at the values in column A and if they are the same, merges the cells in columns F & G in the same rows.
I have no idea how to do this.
You could use this code:
Sub mergeFG()
Dim cell As Range
Dim cell2 As Range
Set cell = Range("A2")
Do While cell.Value <> ""
Set cell2 = cell.Offset(1)
Do While cell2.Value = cell.Value
Set cell2 = cell2.Offset(1)
Loop
Application.DisplayAlerts = False
cell.Offset(0, 5).Resize(cell2.Row - cell.Row).Merge
cell.Offset(0, 6).Resize(cell2.Row - cell.Row).Merge
Application.DisplayAlerts = True
Set cell = cell2
Loop
End Sub
Call mergeFG, either via other code, or link some button to it.
Check the code below. I have assumed that you have sorted Column-A i.e, ref_num and also change the SheetName from "Sample" in code to your workbook sheet name.
Sub merge_cells()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim counter As Integer
Set ws = ThisWorkbook.Worksheets("Sample")
end_row = ws.Range("A65536").End(xlUp).Row
counter = 1
For i = 2 To end_row
If ws.Range("A" & i).Value = ws.Range("A" & i - 1).Value Then
counter = counter + 1
Else
If counter > 1 Then
ws.Range("F" & i - counter).Resize(counter).Merge
ws.Range("G" & i - counter).Resize(counter).Merge
End If
counter = 1
End If
Next i
Application.ScreenUpdating = True
End Sub

put 0 in a next excel column if previous 4 are empty using VBA

Hi all I am trying to make a vb macro that determins are there 4 empty cells in a row if so it should put 0 in a next row otherwais 1 Here is what I 've done so far
Sub QuickCull()
On Error Resume Next
Columns("a").SpecialCells(xlBlanks).EntireRow.Delete
Columns("b").SpecialCells(xlBlanks).EntireRow.Delete
Columns("d").SpecialCells(xlBlanks).EntireRow.Delete
Dim col As Range
Set col = Cells(Rows.Count, "E").End(xlUp)
Dim r As Range
Set r = Range("E2", col).Resize(, 4)
r.Select
Dim cell As Range
For Each cell In r
If cell.Value = "" Then
cell.Value = 0
Else
cell.Value = 1
End If
Next cell
End Sub
This way I put 0 instad of one blank row I thought about making another cell with a sum of those rows, but is where a way to do it more queckly and productivly?
I think you need something like the following, obviously replace "WORKSHEETNAME" with the name of the worksheet:
Dim r as Range, cell as Range, eRow as Long
eRow = Sheets("WORKSHEETNAME").Cells(Rows.Count, 5).End(xlUp).Row
Set r = Sheets("WORKSHEETNAME").Range("E2:E" & eRow)
For each cell in r.cells
If cell.Offset(0,-4).Value = "" _
And cell.Offset(0,-3).Value = "" _
And cell.Offset(0,-2).Value = "" _
And cell.Offset(0,-1).Value = "" Then
cell.Value = 0
Else
cell.Value = 1
End if
Next cell

Resources