I want to learn how to create a symmetric matrix in VBA. For example in the first step I want to choose Range("C3:I3") then copy to the Range("B4:B10"). In the second stage it should choose Range("D4:I4") then copy to the Range("C5:C10"). It should go on like that.
I have some code to do it. Your selected cell must be within the range of numbers.
1. If the diagonal line is empty.
►
The code:
Sub making_symmetric_matrix()
Dim i As Long, j As Long
Dim rng As Range
Set rng = Selection.CurrentRegion
Dim rngStart As Range
Set rngStart = Cells(rng.Row, rng.Column - 1)
For i = 1 To rng.Rows.Count
For j = i To rng.Columns.Count
rngStart.Offset(j, i - 1).Value = rngStart.Offset(i - 1, j).Value
Next
Next
End Sub
2. If the diagonal line is not empty.
►
The code:
Sub making_symmetric_matrix2()
Dim i As Long, j As Long
Dim rng As Range
Set rng = Selection.CurrentRegion
Dim rngStart As Range
Set rngStart = Cells(rng.Row, rng.Column)
For i = 1 To rng.Rows.Count
For j = i To rng.Columns.Count
rngStart.Offset(j - 1, i - 1).Value = rngStart.Offset(i - 1, j - 1).Value
Next
Next
End Sub
You don't need VBA to do that. Select the cells and copy them. Select the top cell of the target range, use Paste Special and tick the box for "Transpose".
If you really need VBA to do this, you definitely don't need a loop as suggested in the other post. Just use the transpose option in the VBA code. For a large data set this will be a lot faster than looping through each cell.
Range("C3:I3").Copy
Range("B4").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Related
Sub Add_Leading_Zeros()
Dim LastColumn As Integer
LastColumn = ActiveSheet.Cells(Columns.Count, 1).End(xlUp).Column
Dim LastRow As Integer
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim HeaderRange As Range, HeaderCell As Range
Set HeaderRange = Range("A1:A" & LastColumn)
For Each HeaderCell In HeaderRange
If InStr(1, HeaderCell.Value, "Title") > 0 Or InStr(1, HeaderCell.Value, "title") > 0 Then
Dim TitleRange As Range, TitleCell As Range
Set TitleRange = 'range of that cell's used cells in that column
'Add Zeroes to front of number until total numbers = 4
End Sub
Above is a rough outline of what I'm aiming for. I want to have my macro scan a row and if any cells in that row match a word then I want to add 0's to the front of each cell in that column until each cell has a total of 4 numbers. Essentially adding leading zeros.
Am I on the right track? What can I do to look up solutions or learn? I would like help writing this code but I also want to understand the thought process behind the decisions so I can continue my learning.
Sub Add_Leading_Zeros()
Dim sht As Worksheet
Dim HeaderRange As Range, HeaderCell As Range, c As Range
Set sht = ActiveSheet
For Each HeaderCell In sht.Range(sht.Range("A1"), sht.Cells(1, Columns.Count).End(xlToLeft)).Cells
If LCase(HeaderCell) Like "*title*" Then
For Each c In sht.Range(HeaderCell.Offset(1, 0), _
sht.Cells(Rows.Count, HeaderCell.Column).End(xlUp)).Cells
If Len(c.Value) > 0 Then
c.NumberFormat = "#" 'Text
c.Value = Right("0000" & c.Value, 4)
End If
Next c
End If
Next HeaderCell
End Sub
If you want to add a leading zero to a cell:
cells(i,1).value = "0" & cells(i,1).value
The rest of your approach looks fine, in terms of what you're aiming to do... you've got quite a few issues with syntax, e.g., cells(1,columns.count) versus cells(rows.count,1).
I would say to be careful on the terms you're using to describe. You are looking down a column and different rows, from what I can read in your code, but your post talks about finding items in a row.
If you are going down a column, you can use application.match to help determine if you have anything matching cells above your current cell, similar to:
Dim i As Long, lr As Long
With Sheets(1)
lr = .Cells(Rows.Count, 4).End(xlUp).Row)
For i = 2 To lr
On Error Resume Next
If Application.Match(.Cells(i, 4), .Range(.Cells(1, 1), .Cells(lr, 1)), 0) > lr Then .cells(i,1).value = "0" & .cells(i,1).value
Next i
End With
I am very new at vba, and now fighting with one macro which will filter a Column by the first exact letters (for instance, I have a Column N - “City” and as a result I have to have all entries , starts for instance- “Vancouver”, “Vancouver. BC”, “Vancouver Canada” – so I want to sort this column by the first letters – VANCOU - to be sure, that I will not miss any info.
The code below does not work at all for 3 values – probably I choose a wrong way ., can you please advise – which function or operator will work at this case? All I find - work for 2 values (at that case I can use at list "begins with"). I have 5-6 values, and they might vary (I don't know which format of City name I will have next time) .
Thanks in advance!
Dim rng01 As Range
Set rng01 = [A1:Z5048]
rng01.Parent.AutoFilterMode = False
rng01.Columns(14).AutoFilter Field:=1, Criteria1:=Array("Vancou*", "Brampt*", "Halifa*"), Operator:= _
xlFilterValues
Upd:
Here is an adapted code , which is not working
Option Explicit
Sub AutoFilterWorkaround()
Dim sht As Worksheet
Dim filterarr As Variant, tofindarr As Variant
Dim lastrow As Long, i As Long, j As Long, k As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "N").End(xlUp).Row
'List the parts of the words you need to find here
tofindarr = Array("Vancou", "Brampt", "Halifa")
ReDim filterarr(0 To 0)
j = 0
For k = 0 To UBound(tofindarr)
For i = 2 To lastrow
If InStr(sht.Cells(i, 14).Value, tofindarr(k)) > 0 Then
filterarr(j) = sht.Cells(i, 14).Value
j = j + 1
ReDim Preserve filterarr(0 To j)
End If
Next i
Next k
'Filter on array
sht.Range("$N$1:$N$" & lastrow).AutoFilter Field:=14, Criteria1:=Array(filterarr), Operator:=xlFilterValues
End Sub
Okay, so I rewrote the workaround - basically we avoid using wildcards by just finding each individual match case, loading that into an array, then filter on the entire array at the end.
This example works for column A - just change the A in lastrow to N, as well as changing the As to Ns in the last line. Also specify your sheet name on the Set sht line. Also Field:=1 needs to be changed to Field:=14 for column N in your case.
Option Explicit
Sub AutoFilterWorkaround()
Dim sht As Worksheet
Dim filterarr As Variant, tofindarr As Variant
Dim lastrow As Long, i As Long, j As Long, k As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'List the parts of the words you need to find here
tofindarr = Array("Vancou", "Brampt", "Halifa")
ReDim filterarr(0 To 0)
j = 0
For k = 0 To UBound(tofindarr)
For i = 2 To lastrow
If InStr(sht.Cells(i, 1).Value, tofindarr(k)) > 0 Then
filterarr(j) = sht.Cells(i, 1).Value
j = j + 1
ReDim Preserve filterarr(0 To j)
End If
Next i
Next k
'Filter on array
sht.Range("$A$1:$A$" & lastrow).AutoFilter Field:=1, Criteria1:=Array(filterarr), Operator:=xlFilterValues
End Sub
Actual work to loop through the Column A which has same value of with certain range, with that range have to check the latest date with the comment in Column B and print the comment with date in Column C kindly help me to find the solution for this problem.. Or Guide to find the solution for this problem... Kindly check the Screenshot for clear information.. Thanks in Advance Experts
Loops are probably the most powerful things is all computer programming topics. Please see the examples below for some ideas of how to achieve your goals.
For Each cell in a range
data for each example
One of the most common things you will do when programming VBA in Excel is looping though a collection of cells in a specified range, as in the example below which prints the Address and Value of 4 cells on the 'Data' worksheet to the immediate window: $B$2:a, $C$2:b, $B$3:1, $C$3:2.
Dim rng As Range: Set rng = Application.Range("Data!B2:C3")
Dim cel As Range
For Each cel In rng.Cells
With cel
Debug.Print .Address & ":" & .Value
End With
Next cel
Loop through the cells in a row
data for each example
The code below shows how to loop through the cells in the row with RowIndex:=2. Applied to the data in the sheet on the right this will return 1, 2. From this we see that rows are counted from the starting point of rng, so the row is 3 on the worksheet, 2 inside rng. Also, only cells inside the set range rng are taken.
Dim rng As Range: Set rng = Application.Range("Data!B2:C3")
Dim i As Integer
For i = 1 To rng.Rows.Count
Debug.Print rng.Cells(RowIndex:=2, ColumnIndex:=i).Value
Next
Loop through the cells in a column
The code below shows how to loop through the cells in the column with ColumnIndex:=B. Applied to the data in the sheet on the right this will return a, 1, 2. From this we see that columns are counted from the starting point of rng, so the column is C on the worksheet, B inside rng. Also, only cells inside the set range rng are taken.
Dim rng As Range: Set rng =
Dim i As Integer
For i = 1 To rng.Rows.Count
Debug.Print rng.Cells(RowIndex:=i, ColumnIndex:="B").Value
Next
Loop through the columns in a range
The code below shows how to loop through the columns in the Range B2:C4. Applied to the data in the sheet on the right this will return 2, 3. From this we see that columns are counted from the starting point of the worksheet.
Dim rng As Range: Set rng = Application.Range("B2:C4")
Dim col As Range
For Each col In rng.Columns
Debug.Print col.Column
Next col
Loop through the rows in a range
The code below shows how to loop through the rows in the Range B2:C4. Applied to the data in the sheet on the right this will return 2, 3, 4. From this we see that rows are counted from the starting point of the worksheet.
Dim rng As Range: Set rng = Application.Range("B2:C4")
Dim col As Range
For Each col In rng.Rows
Debug.Print col.Row
Next col
Loop through the areas in a range
data for each 2 areas example
Often we assume a range to have a rectangular shape, but this need not be the case. The example sheet on the right shows a selection containing two areas: Selection.Address returns $B$2:$C$3,$F$2:$F$3. Such a situation may also occur as a result of the Intersect method, or other causes. To handle the two ranges separately can can pick then from the Areas collection:
Dim rng As Range: Set rng = Application.Selection
Dim rngArea As Range
For Each rngArea In rng.Areas
Debug.Print rngArea.Address
Next rngArea
I would recommend declaring some dimensions in a fairly simple approach (assumes you have sorted Column A):
Dim i As Long, j As Long, k As Long, LR As Long
LR = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LR
If Cells(i, 1).Value = Cells(i - 1).Value Then
If j = 0 Then
j = Cells(i - 1, 1).Row
End If
Else
If j > 0 Then
k = Cells(i - 1, 1).Row
Cells(j, 3).Value = Application.Max(Range(Cells(j, 1), Cells(k, 1)))
j = Cells(i, 1).Row
k = 0
End If
End If
Next i
I'm brand new to VBA for excel (like a few hours ago new) and not really a programmer, so bear with me.
I have an excel data set, all in one column (column A) that is structured like this:
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
That is, the data blocks are separated by blank rows, but not at regular intervals. I'm trying to write a macro that will go through the file and Group (the specific excel command) these blocks of data together. So far I have this:
Set firstCell = Worksheets("627").Range("A1")
Set currentCell = Worksheets("627").Range("A1")
Do While Not IsEmpty(firstCell)
Set firstCell = currentCell
Do While Not IsEmpty(currentCell)
Set nextCell = currentCell.Offset(1, 0)
If IsEmpty(nextCell) Then
Range("firstCell:currentCell").Select
Selection.Rows.Group
Set firstCell = nextCell.Offset(1, 0)
Else
Set currentCell = nextCell
End If
Loop
Loop
I'm sort of stuck, having particular trouble with the logic of moving to the next block of data and initiating.
Any help would be appreciated!
How about something like this:
Option Explicit
Public Sub tmpTest()
Dim i As Long
Dim lngLastRow As Long
With ThisWorkbook.Worksheets(1)
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lngLastRow To 1 Step -1
If .Cells(i, 1).Value2 = vbNullString Then
.Range(.Cells(i + 1, 1), .Cells(lngLastRow, 1)).EntireRow.Group
lngLastRow = i - 1
End If
Next i
.Range(.Cells(1, 1), .Cells(lngLastRow, 1)).EntireRow.Group
End With
End Sub
Here ya are. You just need to pull addresses in your range instead of trying to refer to the object. You also need to reset both current and first cell in your if statement.
Sub test()
Set firstCell = Worksheets("test2").Range("A1")
Set currentcell = Worksheets("test2").Range("A1")
Do While Not IsEmpty(firstCell)
Set firstCell = currentcell
Do While Not IsEmpty(currentcell)
Set nextcell = currentcell.Offset(1, 0)
If IsEmpty(nextcell) Then
Range(firstCell.Address, currentcell.Address).Select
Selection.Rows.group
Set currentcell = nextcell.Offset(1, 0)
Set firstCell = nextcell.Offset(1, 0)
Else
Set currentcell = nextcell
End If
Loop
Loop
End Sub
First of all, your code goes wrong when it says
Range("firstCell:currentCell").Select
You are trying to select the range named "firstCell:currentCell" instead of
selecting range from first Cell to currentCell
You should change it to
.Range(firstCell,currentCell).select
Try using below code and see if it does what you want it to do
Dim GROUP_LAST_CELL As Range
With Worksheets("627")
LAST_ROW = .Range("A" & Rows.Count).End(xlUp).Row
I = 1
While I <= LAST_ROW
Set GROUP_LAST_CELL = .Cells(I, 1).End(xlDown)
.Range(.Cells(I, 1), GROUP_LAST_CELL).Rows.Group
I = GROUP_LAST_CELL.Row + 2
Wend
End With
According to what i understood from the question, i think what you want to do is to loop across all the elements in a particular column, skipping all the blanks.
You can do so by
Calculating the lastrow of the column
Looping across from the first row count to the calculated lastRow count
Applying a condition within the loop to only print the non-empty cells
Code Block
Sub test()
Dim j As Long, lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To lastRow
If Cells(j, "A").Value <> "" Then
MsgBox (Cells(j, "A").Value)
End If
Next j
End Sub
I Hope this helped!
I need some help with this macro. I have a workbook that is formatted pretty poorly, but consistently every time I open it. Among other things, the goal is to find the non-blank cells in column B and delete the entire 2 rows below and the 1st row above each of those populated B cells.
The first loop I have in the code works just the way I want it to, but the second loop seems to only work on the 1st instance of a populated B cell, but then it deletes everything else above it, like 500 cells worth of data.
Can someone explain to me why this is happening, and if you could find a way to combine both of those for loops into 1, that would be nice too.
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long, lastCol As Long
Dim colNames As Variant
Dim i As Integer, j As Integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1 Step -1
If currentSht.Cells(i, "B").Value <> "" Then
currentSht.Cells(i, "B").Offset(1).EntireRow.Delete
End If
Next i
Range("D3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlUp
currentSht.Rows("1:1").EntireRow.Delete
currentSht.Range("c:d, f:g, i:k").EntireColumn.Delete
currentSht.Range("A:D").Columns.AutoFit
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").Value <> "" Then
currentSht.Range(Cells(j, "B").Offset(-1), Cells(j, "B").Offset(-3)).EntireRow.Delete
End If
Next j
End Sub
Thank you
The second loop deletes everything because upon deletion of the lines above the found value, said value gets moved up and will be found again, triggering another deletion. To fix this, the quickest way would be to skip the next two lines by modifying j:
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").Value <> "" Then
currentSht.Range(Cells(j, "B").Offset(-1), Cells(j, "B").Offset(-3)).EntireRow.Delete
j = j - 2
End If
Next j
It really doesn't matter much if you are looping from top to bottom or vice versa. The only difference would be if there are two entries in column B near each other. In that case, the search order would determine which one is deleted. But is deletion really what you want? Maybe you could .Clear the contents of the rows instead of deleting them.
edit: here's the new code a bit cleaned up
Sub test()
Dim currentSht As Worksheet
Dim startCell As Range
Dim lastRow As Long, lastCol As Long
Dim colNames As Variant
Dim i As Integer, j As Integer
Set currentSht = ActiveWorkbook.Sheets(1)
Set startCell = currentSht.Range("A1")
lastRow = startCell.SpecialCells(xlCellTypeLastCell).Row
lastCol = startCell.SpecialCells(xlCellTypeLastCell).Column
For i = lastRow To 1 Step -1
If currentSht.Cells(i, "B").value <> "" Then
'reference the row directly
currentSht.Rows(i + 1).Delete
End If
Next i
'Do not use selection if you can avoid it
Range("D3", Range("D3").End(xlToRight)).Delete Shift:=xlUp
currentSht.Rows(1).Delete
currentSht.Range("C:D, F:G, I:K").Delete
currentSht.Range("A:D").Columns.AutoFit
For j = lastRow To 2 Step -1
If currentSht.Cells(j, "B").value <> "" Then
currentSht.Rows(j - 1).Delete
currentSht.Rows(j - 2).Delete
j = j - 2
End If
Next j
End Sub
If you want to combine the loops the behavior of the macro will change because of the deletions that happen between the loops.