AlexP provided the following code to a question about copying columns. It works great for me except that in ws1, the columns have equations that get copied over to ws2. I just want to copy over the values, not the equations.
Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("ws1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("ws2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function
Just split this line:
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
and use the .PasteSpecial() method instead
e.g.
Range(header.Offset(1, 0), header.End(xlDown)).Copy
Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value)).PasteSpecial(xlPasteValues)
Application.CutCopyMode = False
Related
I'm trying to auto fill a row of formulas to the row before it.
I'm on excel 2010. I know that the ranges I'm using in the autofill function are the right ranges, I checked by adding in the select function and going line by line to make sure it selected the right ones.
Sub NewIC()
Dim v As Range, newV As Range, oldVRow As Range, newVRow As Range
Dim s As Range
Dim dc As Range
With Sheets("Charts").Cells
'Inserting name into Vios
Set v = .Find("Vios", LookIn:=xlValues)
If Not v Is Nothing Then
v.Select
ActiveCell.Offset(4, 0).Select
With Selection.EntireRow.Insert(xlShiftDown, xlFormatFromRightOrBelow)
Set newV = ActiveCell
Range("T1").Copy newV
newV.Font.Bold = True
End With
End If
'Dragging up formulas
Set oldVRow = Range(newV.Offset(-1, 1), newV.Offset(-1, 8))
Set newVRow = Range(newV.Offset(0, 1), newV.Offset(0, 8))
oldVRow.Select
newVRow.Select
newVRow.AutoFill Destination:=oldVRow, Type:=xlFillDefault
End With
End Sub
All of the code works up until the last line. It sets the right cell as newV, sets the right ranges, but I get the error
Run-time error '1004' AutoFill method of Range class failed
Modify:
Set newVRow = Range(newV.Offset(0, 1), newV.Offset(0, 8))
to include the row above:
Set newVRow = Range(newV.Offset(-1, 1), newV.Offset(0, 8))
and change:
newVRow.AutoFill Destination:=oldVRow, Type:=xlFillDefault
to:
oldVRow.AutoFill Destination:=newVRow, Type:=xlFillDefault
You don't need to use all this Select:
'oldVRow.Select ' comment this row
'newVRow.Select ' comment this row
My problem while using Excel VBA is trying to verify if there are cells of a certain color in a sheet of a workbook (workbookB) before applying a filter by color (RGB(1, 255, 1)) on a sheet (SheetNameFromArray) and then copy the visible cells to another workbook (workbookA) sheet with the same name (SheetNameFromArray).
The solution I tried involved using "Application.CountIf(range, condition)" to count the cells that had the color RGB(1, 255, 1) and then if there are cells with the color, proceed to filter and copy. But, for some reason, it seems to not count the cells properly because it never copies any cell even when the sheet has cells with that color inside the range (see example below):
LastSheetRow = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row
LastSheetColumn = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(1, Columns.Count).End(xlToLeft).Column
WorkbookALastSheetRow = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row
Dim rngWorkbookBToCopy As Range, rngWorkbookAToPaste As Range
With Workbooks(WorkbookB).Sheets(SheetNameFromArray)
Set rngWorkbookBToCopy = .Range(.Cells(2, 1), .Cells(LastSheetRow, LastSheetColumn - 1))
End With
With Workbooks(WorkbookA).Sheets(RevisionSheetNameFromArray)
Set rngWorkbookAToPaste = .Cells(WorkbookALastSheetRow, 1)
End With
If Application.CountIf(rngWorkbookBToCopy, RGB(1, 255, 1)) = 0 Then
Else
With Workbooks(WorkbookB).Worksheets(RevisionSheetNameFromArray)
.Range(.Cells(1, 1), .Cells(LastSheetRow, LastSheetColumn)).AutoFilter Field:=1, Criteria1:=RGB(1, 255, 1), Operator:=xlFilterCellColor
End With
rngWorkbookBToCopy.SpecialCells(xlCellTypeVisible).Copy rngWorkbookAToPaste
End If
What I would like to do is copy only the range of rows that have at least a cell colored in RGB(96, 255, 210). I added the condition to check if there are cells of the said color because if the sheet didn't have cells, an error of range Autofilter property appeared. But, as I said, it seems to not count the cells properly and I am not sure about how to solve it.
Please help me and thanks in advance (& sorry for my bad English)
I found a workaround based on this post at Microsoft support.
One has to create a function that receives the range of cells to be analyzed and the criteria of the interior color of the cells that one wants to count. This function behaves is some way as what the CountIf was expected to do for the question post (count the cells that have a certain interior color).
Function CountCcolor(range_data As Range, criteria As Long) As Long
Dim datax As Range
Dim xcolor As Long
xcolor = criteria
For Each datax In range_data
If datax.Interior.Color = xcolor Then
CountCcolor = CountCcolor + 1
End If
Next datax
End Function
Applying this change, the code now would be as follows:
LastSheetRow = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row
LastSheetColumn = Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(1, Columns.Count).End(xlToLeft).Column
WorkbookALastSheetRow = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Cells(Rows.Count, 1).End(xlUp).Row
Dim rngWorkbookBToCopy As Range, rngWorkbookAToPaste As Range
With Workbooks(WorkbookB).Sheets(SheetNameFromArray)
Set rngWorkbookBToCopy = .Range(.Cells(2, 1), .Cells(LastSheetRow, LastSheetColumn - 1))
End With
With Workbooks(WorkbookA).Sheets(RevisionSheetNameFromArray)
Set rngWorkbookAToPaste = .Cells(WorkbookALastSheetRow, 1)
End With
If CountCcolor(rngWorkbookBToCopy, RGB(1, 255, 1)) = 0 Then
Else
With Workbooks(WorkbookB).Worksheets(RevisionSheetNameFromArray)
.Range(.Cells(1, 1), .Cells(LastSheetRow, LastSheetColumn)).AutoFilter Field:=1, Criteria1:=RGB(1, 255, 1), Operator:=xlFilterCellColor
End With
rngWorkbookBToCopy.SpecialCells(xlCellTypeVisible).Copy rngWorkbookAToPaste
End If
I hope it helps other people that may encounter this situation.
I have a vba code to swap two row ranges (excluding column A) but need it to ignore cells that contain a formula (in this case columns K&L). The code I have below works fine but messes up the formulas in columns K&L! Can anyone advise how best to overcome this?
Sub swap()
If Selection.Areas.Count <> 2 Then Exit Sub
Set range1 = Selection.Areas(1)
Set range2 = Selection.Areas(2)
Set range1 = range1.Resize(, 100)
Set range2 = range2.Resize(, 100)
If range1.Rows.Count <> range2.Rows.Count Or _
range1.Columns.Count <> range2.Columns.Count Then Exit Sub
range1Address = range1.Address
range1.Cut
range2.Insert shift:=xlShiftToRight
Range(range1Address).Delete shift:=xlToLeft
range2Address = range2.Address
range2.Cut
Range(range1Address).Insert shift:=xlShiftToRight
Range(range2Address).Delete shift:=xlToLeft
End Sub
If you're just trying to swap their locations, use only the column #s to make it a little easier:
Dim col1 As Long, col2 As Long
If Selection.Areas.Count <> 2 Then Exit Sub
col1 = Selection.Areas(1).Column
col2 = Selection.Areas(2).Column
If Left(Cells(2, col1), 1) = "=" Or Left(Cells(2, col2), 1) = "=" Then Exit Sub 'Should catch if it's a formula
Columns(col1).Cut
Columns(col2).Insert shift:=xlShiftToRight
Columns(col2).Cut
Columns(col1).Insert shift:=xlShiftToRight
Having put formulas into some cells that were being moved, i did not have any issues (simple addition of all cells in the range, 1 by 1, not sum()). The reference locations of the cells in the formula changed to the corresponding new locations and as such didn't change the output of the formula.
You may have run into issues because you deleted values, which could remove references.
I'm sure this will be a quick one for someone. I've found some VBA code that does what I want, I just want it to reference the last row as the last row in column A rather than whatever column it is looking at at that time.
Below is the original code.
Private Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("FPS").Range("A1:BK1") '
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xldown)).Copy Destination:=Worksheets("TempTable").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
And this was my attempt.
Private Sub CopyHeaders()
Dim header As Range, headers As Range
Dim LastRow As Long
Set headers = Worksheets("FPS").Range("A1:BK1") '
rowlast = Worksheets("FPS").Cells(Rows.Count, "A").End(xlUp).Row
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
With Worksheets("FPS")
.Range(.Cells(header.Row + 1, header.Column), .Cells(rowlast, headercolumn)).Copy Destination:=Worksheets("TempTable").Cells(2, GetHeaderColumn(header.Value))
End With
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("TempTable").Range("A1:Y1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function
I feel like I've got the right idea but just don't know how to implement it. Any help and an explanation would be much appreciated as I am very keen to learn.
Thanks in advance
Declare all variables.
Don't set a Long.
Assign the worksheet to ALL Range objects.
Private Sub CopyHeaders()
Dim header As Range, headers As Range
Dim rowlast As Long
Set headers = Worksheets("FPS").Range("A1:BK1") '
rowlast = Worksheets("FPS").Cells(Rows.Count, "A").End(xlUp).row
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
With Worksheets("FPS")
.Range(.Cells(header.row + 1, header.Column), .Cells(rowlast, headercolumn)).Copy _
Destination:=Worksheets("TempTable").Cells(2, GetHeaderColumn(header.Value))
End With
End If
Next
End Sub
The following piece of code works great for me except that it stops when it gets an empty row in the column.
I would like to modify it by determining to copy-paste until the last row in column A. I have made a LASTROW variable, but I can not figure out where to use it exactly.
LASTROW = Range("A" & Rows.Count).End(xlUp).Row
Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("ws1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("ws2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function
Thank you in advance !
Have you tryed this way?
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0).Address, Worksheets("ws1").Cells(Rows.Count, header.Column).End(xlUp).Address).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
End If
Next