I have a code that copies data from one workbook to another. Now, the 2nd column in my destination workbook has a certain color format that I need to be applied till the last column with data in it.
This is the code snippet to find the last non-empty column :
Dim rLastCell As Range
Set ws = ThisWorkbook.Sheets(DestName)
Set rLastCell = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlValues, _
LookAt:= xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
Dim LastCol As Long
LastCol = rLastCell.Column
MsgBox LastCol
So, now I want to iterate and paste the format from the 2nd column to all the columns until LastCol. Any help would be appreciated.
This is the solution :
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
MsgBox "Last Column: " & lCol
Dim x As Long
Columns(2).Copy
For x = 3 To LastCol
Columns(x).PasteSpecial Paste:=xlPasteFormats
Next
Related
I have the code below that copies the last column filled and paste it into the next empty, simple column. However I need the pasted column to be incremented (with autofill), in my case, with date. January> February> March and so on. Today it sticks with the fixed data.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rLastCell As Range
Dim LastCol As Integer
Set rLastCell = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
LastCol = rLastCell.Column
ws.Columns(LastCol).Copy ws.Columns(LastCol + 1)
End Sub
I just started learning VBA, so I would appreciate anyone helping me to solve the problem. I might use the wrong terminology to describe the question, but basically I am trying to write a VBA macro to transpose the data from picture 1 to the layout in picture 2.
Since I can only attach screen shots, I delete other project attribute columns between project title and Item 1 in picture 1, as well as column groups for task 4 to task 8. However, the project title header will always be located at E6, Item 1 header located at AA6 and Item 8 Finish Date header located at AX6.
In picture 2, the header project title will be located at cell B4. The database in sheet 1 will be getting more or less rows, so I want be able to update Sheet2 when I click a button. If possible, also have the macro skip the blank item cells. The ultimate goal is to plot a gantt chart with the data layout. I can do the gantt chart with cell formuala and conditional formating, but I am stuck in getting the desired data layout.
I found a problem similar to my situation but don't know how to modify it to work for groups.
excel macro(VBA) to transpose multiple columns to multiple rows
In that case, "Apple" is more or less equivent to my project 1. "Red" is equivalent to (Item 1, Start 1, Finish 1). "Green" is similar to (Item 2, Start 2, Finish 2), so on and so forth.
Let me know if further clarification is needed. Thanks so much!
Try this, it should do the job even though it might be a bit messy.
Option Explicit
Sub Macro1()
Dim lRow As Long, lastColumn As Long, lngcol As Long
Dim lCol As String, colChar As String, strSearch As String
Dim i As Integer
Dim targetValue As Range, copyValue As Range
Dim wks As Worksheet, targetWks As Worksheet
Dim targetLastRowA As Long, targetLastRowB As Long, targetLastCol As Long
Application.ScreenUpdating = False
Set wks = ThisWorkbook.Sheets("Sheet1")
Set targetWks = ThisWorkbook.Sheets("Sheet2")
lRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
lastColumn = wks.Columns.SpecialCells(xlLastCell).Column
lCol = Col_Letter(lastColumn)
' Loop through rows
For i = 2 To lRow
lngcol = 2
targetLastCol = targetWks.Columns.SpecialCells(xlLastCell).Column
With targetWks
Set targetValue = targetWks.Columns("A:A").Find(What:=wks.Range("A" & i).Value, After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
End With
If targetValue Is Nothing Then
targetLastRowB = targetWks.Cells(targetWks.Rows.Count, "B").End(xlUp).Row
wks.Cells(i, 1).Copy
targetWks.Cells(targetLastRowB + 1, 1).PasteSpecial
Application.CutCopyMode = False
End If
' Loop through columns
For lngcol = 2 To lastColumn Step 3
colChar = Col_Letter(lngcol)
strSearch = wks.Range(colChar & i)
With targetWks
Set copyValue = targetWks.Columns("B:B").Find(What:=strSearch, After:=.Cells(1, 2), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
End With
targetLastRowB = targetWks.Cells(targetWks.Rows.Count, "B").End(xlUp).Row
targetLastRowA = targetWks.Cells(targetWks.Rows.Count, "A").End(xlUp).Row
If copyValue Is Nothing And targetWks.Range("A" & targetLastRowA).Offset(1, 1) = "" Then
wks.Range(wks.Range(colChar & i), wks.Range(colChar & i).Offset(0, 2)).Copy
targetWks.Cells(targetLastRowB, 1).Offset(2, 1).PasteSpecial xlPasteValues
ElseIf copyValue Is Nothing Then
wks.Range(wks.Range(colChar & i), wks.Range(colChar & i).Offset(0, 2)).Copy
targetWks.Cells(targetLastRowB + 1, 2).PasteSpecial xlPasteValues
End If
Application.CutCopyMode = False
Next
Next i
Application.ScreenUpdating = True
End Sub
Function Col_Letter(lngcol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngcol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
I found this cool code that identifies the bottom-most row of data in a worksheet (considering all columns), and then types an X in Column B of the following row.
However I have been unsuccessful at creating a loop with this code, so that each worksheet is treated uniquely. My attempts have typed X in the same cell of all worksheets, but not each worksheet individually based on it's own set of data.
Also note that each of my tabs will not always have the same column be the longest, which is why I needed a code to look across all columns to find the bottom-most row.
Can someone suggest how I can loop this and identify the bottom-most row in each worksheet individually?
Sub EndofData()
Dim iRow As Long
Dim iCol As Long
iRow = Cells.Find(What:=”*”, _
After:=Range(“A1”), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Cells(iRow + 1, 2).Select
ActiveCell.FormulaR1C1 = “x”
End Sub
You want to do a For Each Loop:
Sub EndofData()
Dim ws As Worksheet
Dim iRow As range
Dim iCol As Long
For Each ws In ActiveWorkbook.Worksheets
set iRow = ws.Cells.Find(What:=" * ", _
After:=ws.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If not irow is nothing then
ws.Cells(iRow.Row + 1, 2).FormulaR1C1 = "x"
Else
ws.Cells(1, 2).FormulaR1C1 = "x"
End IF
Next ws
End Sub
Thanks to #Darren for help on the error avoidance.
I have a large sheet. I have to set multiple filters in that sheet to columns headers in dynamic positions. Once the filters are set, I have to find the particular column in the sheet having the column header "Nov" and then obtain the sum of values in that column and import that particular sum value into a different worksheet.
I've written the code up until the part where i can set the filters to multiple columns, but I'm finding it difficult to find the column header and add that column. Below is the code I've written so far.
Sub Button2_Click()
Dim colName As Long
Dim colName1 As Long
Dim colName2 As Long
Dim r As Long
SearchV = Range("A8:DD8").Find(What:="Nov", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
lastrow = Cells(Rows.Count, SearchV).End(xlUp).Row
colName = Range("A8:DD8").Find(What:="Teams", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
colName1 = Range("A8:DD8").Find(What:="Items", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
colName2 = Range("A8:DD8").Find(What:="Domain", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False).Column
ActiveSheet.Range("$A$8:$DD$9999").AutoFilter Field:=colName, Criteria1:="ST Test", Operator:=xlOr, Criteria2:=""
ActiveSheet.Range("$A$8:$DD$9999").AutoFilter Field:=colName1, Criteria1:="Variance", Operator:=xlOr, Criteria2:="(Blanks)"
ActiveSheet.Range("$A$8:$DD$9999").AutoFilter Field:=colName2, Criteria1:="9S", Operator:=xlOr, Criteria2:="(Blanks)"
The column headers always start from the 8th row. Some uesless information is present in the rows above. So what I want is, suppose the column 'Nov' is in H row. The sum should be calculated from H9 to the end of the last row. I had used this formula when the column was in 'H' column.
Cells(lastrow + 1, colName3).Formula = "=SUBTOTAL(9,H9:H" & lastrow & ")"
But the column 'Nov' won't always be present in row 'H', so i'm not able to figure out how to change my code to pick the column dynamically.
Ensure that you fully qualify your objects and also put in a check whether .Find returns something or not. Here is an example.
Let's say your worksheet looks like this
Now try this code
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim aCell As Range, Rng As Range
Dim col As Long, lRow As Long
Dim colName As String
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
Set aCell = .Range("A8:DD8").Find(What:="Nov", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
'~~> If Found
If Not aCell Is Nothing Then
col = aCell.Column
colName = Split(.Cells(, col).Address, "$")(1)
lRow = .Range(colName & .Rows.Count).End(xlUp).Row
'~~> This is your range
Set Rng = .Range(colName & "8:" & colName & lRow)
Debug.Print Rng.Address
'~~> If not found
Else
MsgBox "Nov Not Found"
End If
End With
End Sub
Output
I have a spread sheet and I need to look for the last column that has data in it. Then I need to copy this column and copy it to the next blank column.
Is there a way to do this?
I've managed to do it with rows using:
lastrowSrc = Sheets("Overview").Range("B" & Rows.Count).End(xlUp).Row
However this puts B12 in the range, using columns.count simply puts in the number of the column, not the letter
To get the exact column in a worksheet, use this code.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LastCol As Long
Set ws = Sheets("Sheet1")
'~~> This check is required else .FIND will give you error on an empty sheet
If Application.WorksheetFunction.CountA(ws.Cells) = 0 Then
LastCol = 1
Else
LastCol = ws.Cells.Find(What:="*", _
After:=ws.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End If
Debug.Print LastCol
End Sub
EDIT: This is courtesy #brettdj. You can also use the range object to find the last column
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LastCol As Long
Dim rng As Range
Set ws = Sheets("Sheet1")
Set rng = ws.Cells.Find(What:="*", _
After:=ws.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If rng Is Nothing Then
LastCol = 1
Else
LastCol = rng.Column
End If
Debug.Print LastCol
End Sub
To get the last column of a particular row, say row 1 use this
Debug.Print ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Where ws is your relevant worksheet.
Similarly for Row see this.
I found that some of the answers didn't work for my worksheet that had a few rows at the end that were shorter than the others in the worksheet. The code provided just gives the last column of the last row of the worksheet. Instead, I used a loop around code to find the last column in a row, using the Find example to get the last row in the workbook.
Sub Sample()
Dim ws As Worksheet
Dim CurrRow, RowLastCol, LastRow, LastCol As Long
Set ws = Sheets("Sheet1")
'~~> This check is required else .FIND will give you error on an empty sheet
If Application.WorksheetFunction.CountA(ws.Cells) = 0 Then
LastCol = 1
Else
LastCol = 0
LastRow = ws.Cells.Find(What:="*", _
After:=ws.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
' Loop through all the rows of the sheet saving off the highest column count
For CurrRow = 1 to LastRow
RowLastCol = ws.Cells(CurrRow, Columns.Count).End(xlToLeft).Column
If RowLastCol > LastCol Then
LastCol = RowLastCol
End If
Next CurrRow
End If
Debug.Print LastCol
End Sub