I'm currently transposing data from column to a row in a different spreadsheet one at a time. I began using the "record macro" function but I'm having trouble. I need the macro to copy data column by column and transpose it into a corresponding row, 15 rows apart. There are 100 entries per document. For example; P4 - P23 in document 1 needs to be transposed to M217 - AF217 in document 2. Q4 - Q23 needs to be transposed to M232 - AF 232, up to row 1501.
You can use this simple sub to transpose ranges.
Just give it the source and destination as a range:
Sub TransposeRange(SourceRange As Range, DestinationRange As Range)
SourceRange.Copy
DestinationRange.PasteSpecial Transpose:=True
End Sub
'Example:
Sub MoveRange()
Call TransposeRange(Range("P4:P24"), Range("M232"))
End Sub
'Transpose columns 1-10 and put them row by row at column O
Sub MoveColumns()
For x = 1 To 10
Call TransposeRange(Intersect(UsedRange, Cells(1, x).EntireColumn), Cells(x, 15))
Next x
End Sub
Result:
Related
I receive excel files from a bank that contains information that I need in a certain column. So I want to loop through the specific column and get the values of those cells. Lets say I select column B. I start at B1 and loop through the column cells. But once I get to a merged cell, which there are quite a lot of, the merged cell throws me off of column B when I try to move past it. I'm using Offset(1, 0) to go down the column.
'Here is a quick example of how the selected cell will move
'I'm using an index to move down 15 cells
'Merge cell A2 and B2 before running the macro
Sub test()
Dim index As Integer
index = 0
Range("B1").Select
Do While index < 15
Selection.Offset(1, 0).Select
index = index + 1
Loop
End Sub
The selection moves from B1 to B2, which is merged with A2, then continue to A3 instead of B3.
Using Select is not a best practice, but if you need it for some visual reasons, the code below would work. It gets a starting cell startingRange and each time it loops one row down from it - startingRange.Offset(rowoffset:=index).Select
Sub TestMe()
Dim index As Long
index = 0
Dim startingRange As Range
Set startingRange = Worksheets(1).Range("B1")
Do While index < 15
startingRange.Offset(rowoffset:=index).Select
Application.Wait (Now + #12:00:01 AM#)
index = index + 1
Loop
End Sub
The Application.Wait (Now + #12:00:01 AM#) is added in order to visualize the Seleced cell better.
You should do this without using Select, VBA can address any cell in your workbook without selecting it first and find out what value it contains. There are doubtless different ways of doing what you want to achieve, but this example explains how to move through a column without it deviating:
Sub test()
For Each Cell In Range("B1:B14").Cells
'Finds the MergeArea of the Cell and gets the value from the top left cell
MsgBox Cell.MergeArea.Cells(1, 1).Value
Next
End Sub
When you run the sub it'll fire off Message Boxes containing the values of the cells in column B, rows 1-14, including those that are merged.
This is probably an incomplete answer, your final answer may be a mixture of the code in this example plus the code in your original question.
I have a spreadsheet for measuring costing. All the data is stored within a table. I want to add or delete rows from the table.
Columns A, B and C have data validation lists stored on another tab. Columns D and E are the number of units and number of workers. F, G and H are total rows. F is the unit cost without tax. That is all in a table but there is a formula out in cell M that the formula in cell F makes reference to.
The first row in the table is row 7 and the cell M formula is
=IF(OR(ISBLANK(A7),ISBLANK(B7),ISBLANK(C7)),0,VLOOKUP(CONCATENATE(A7," ",B7," ",C7),Service_Price_List,2,FALSE))
I can't code but I found some code to add and delete a row.
The formulas fill down within the table so it updates the formulas to the correct dynamic formulas in columns F, G and H. The cells within the table update correctly when I add a row but the first time I add a row after performing another action, the cell in column M is added but referencing is wrong.
You might be at row 8, 12 or 13 etc. (any row) but it will put this formula in the cell
=IF(OR(ISBLANK(A7),ISBLANK(B7),ISBLANK(C7)),0,VLOOKUP(CONCATENATE(A7," ",B7," ",C7),Service_Price_List,2,FALSE))
which is the formula from the first cell in the list. If I then try to add another row, (click the add row button twice), the cell will be blank.
As the insert and delete buttons work, I think I need a way to copy the formula from M7, which would be the top of the list. Or would it be better to have the formula inserted dynamically through VBA?
This is the code for my button to add a row:
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim tbl As ListObject
Set tbl = ws.ListObjects("table3")
'add a row at the end of the table
tbl.ListRows.Add
End Sub
This is the code for my button to delete a row:
Private Sub CommandButton4_Click()
Dim oLst As ListObject
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:=""
If ActiveSheet.ListObjects.Count > 1 Then
For Each oLst In ActiveSheet.ListObjects
With oLst
If .Name = "Table3" Then
If oLst.ListRows.Count > 1 Then
number_of_columns = .ListColumns.Count
oLst.ListRows(oLst.ListRows.Count).Delete
End If
End If
End With
Next
'ActiveSheet.Protect Password:=""
End If
End Sub
I implemented a button that ask the user where to add a column, and the button takes the user input(A-Z) and generates the column until the end of the table NOT SPREADSHEET. The column ends based on how many rows there are in my table, meaning if there are 10 rows, after the user clicks the button an inputs where they want the column to be(They input a letter of the column A-Z), I should not see a column box on line 11 of the spreadsheet.
Now I've managed to do this my issue is below:
My issue is the cells the button generate does not include the lines or boxes around the cells so that you are aware that its an extension of the table?
here is what I mean: Picture of spreadsheet
notice the i column there are no lines around the cells?
Here is code, I think I am missing a copy function after the line
shift:=xlRight, but I don't know how to implement it?
I don't want to use macros because since the tables rows and column change due to the user's input I will have to constantly hard-code the range into the macro which i dont want.
Trust me I tried it an its annoying.
Private Sub CommandButton2_Click()
Dim x As Variant
Dim ColumnNum
x = InputBox("Enter a column that you want to add: ", "What column?")
If x = "" Then Exit Sub
ColumnNum = x
ThisWorkbook.Sheets("Sheet1").Columns(ColumnNum).Insert shift:=xlRight
ThisWorkbook.Sheets("Sheet1").Columns(ColumnNum).ClearContents
End Sub
you could try this:
Private Sub CommandButton2_Click()
Dim colIndex As Variant
colIndex = Application.InputBox("Enter a column that you want to add: ", "What column?", , , , , , 2) '<--| force a text
If colIndex = "" Then Exit Sub
With ThisWorkbook.Sheets("Sheet1").Columns(colIndex) '<--| reference column you want to insert
.Insert shift:=xlRight '<--| insert a new column , then the referenced one shifts one column to the right of the inserted one
.Offset(, -2).Copy '<--| copy the column two columns to the left of the referenced one (i.e. one column left of the new one)
.Offset(, -1).PasteSpecial xlPasteFormats '<--| paste formats to the new column
Application.CutCopyMode = False
End With
End Sub
Trying to run a macro in Excel to remove non dupes so dupes can be examined easily.
Step through each cell in column "B", starting at B2 (B1 is header)
During run, if current cell B has a match anywhere in column B - leave it, if it' unique - remove entire row
The code below is executing with inconsistent results.
Looking for some insight
Sub RemoveNonDupes()
Selection.Copy
Range("B2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("B2:B5000").AdvancedFilter Action:= xlFilterInPlace, CriteriaRange:= Range("B2"), Unique := True
Range("B2:B5000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.showalldata
End Sub
Not the most direct route, but you could have the macro insert between B and C. Then dump a formula in that column that counts.
Something like =countifs(B:B,B:B) That will give you a count of how many times a record shows, then you can set the script to Loop deleting any row where that value is 1.
Something like
Sub Duplicates()
Columns("B:B").Insert Shift:=xlToRight ' inserts a column after b
count = Sheet1.Range("B:B").Cells.SpecialCells(xlCellTypeConstants).count ' counts how many records you have
crange = "C1:C" & count ' this defines the range your formula's go in if your data doesn't start in b1, change the c1 above to match the row your data starts
Sheet1.Range(crange).Formula = "=countifs(B:B,B:B)" ' This applies the same forumla to the range
ct=0
ct2=0 'This section will go cell by cell and delete the entire row if the count value is 1
Do While ct2 < Sheet1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
For ct = 0 To Sheet1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
If Sheet1.Range("C1").Offset(ct, 0).Value > 1 Then
Sheet1.Range("C1").Offset(ct, 0).EntireRow.Delete
End If
Next
ct2 = ct2 + 1
Loop
Sheet1.Columns("B:B").EntireColumn.delete
end sub
Code isn't pretty, but it should do the job.
**Updated code per comments
Sub Duplicates()
Columns("C:C").Insert Shift:=xlToRight ' inserts a column after b
count = Activesheet.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count ' counts how many records you have
crange = "C1:C" & count ' this defines the range your formula's go in if your data doesn't start in b1, change the c1 above to match the row your data starts
Activesheet.Range(crange).Formula = "=countifs(B:B,B:B)" ' This applies the same forumla to the range
ct=0
ct2=0 'This section will go cell by cell and delete the entire row if the count value is 1
'''''
Do While ct2 < Activesheet.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
For ct = 0 To Activesheet.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
If Activesheet.Range("C1").Offset(ct, 0).Value = 1 Then
Activesheet.Range("C1").Offset(ct, 0).EntireRow.Delete
End If
Next
ct2 = ct2 + 1
Loop
ActiveSheet.Columns("C:C").EntireColumn.delete
end sub
You can try that updated code, the part with the Do Loop is what will delete each column, I fixed it to delete any row where the count is 1.
Based on what I understand, your data should be in column B and the counts should be in column C. If that isn't correct, update the formula's to match
Chris, to examine the unique values in a given range of data, I suggest utilizing Excel's Advanced Copy function in a slightly different way:
Range("RangeWithDupes").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("TargetRange"), unique:=True
The operation will provide you a list of unique values from 'RangeWithDupes' located at 'TargetRange'. You can then use the resultant range to manipulate the source data in many ways. Hope this helps.
I am trying to print a report from a sheet called Patrol based on the date of the data.
Range A1 contains different dates but I only want to print the data in rows with first row = to (date + 1) ie tomorrows date.(To print delivery details for the next day)
For each row there is date and 16 other cells. The code below is only printing the table headers
Private Sub Comprintpatrol_Click()
Range("A1").AutoFilter Field:=1, Criteria1:=Format(Date + 1, Range("A2").NumberFormatLocal)
ActiveSheet.PrintOut
' or
Range("A1").CurrentRegion.PrintOut
Range("A1").AutoFilter
End Sub
Any Ideas?
I think you're off in saying "Range A1 contains different dates". I think you mean "Column A contains different dates". (Range A1 is a single cell, the upper-left cell on the sheet)
You can get column a from the Range function by passing the string "A:A": Range("A:A")
You could also try the UsedRange instead of CurrentRegion. The latter can be tricky because it depends a lot on how your data are set (especially if you have empty cells).
Something like:
Private Sub Comprintpatrol_Click()
Range("A1").AutoFilter Field:=1, Criteria1:=Format(Date + 1, Range("A2").NumberFormatLocal)
ActiveSheet.PrintOut
' or
ActiveSheet.UsedRange.PrintOut
Range("A1").AutoFilter
End Sub