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.
Related
I want to copy some data from 2 columns ("Nastavit D" sheet, column Q2 to R1000) to the end of the columns with similar data on another sheet ("Chain" sheet, column A1 to B1000). I have a code for this, but I need improvement so that it copies the border formats too. Also, If cell C3 in sheet called "Nedotykat sa!!!" is TRUE, then I want it to copy the data to Sheet called "Chain" BEFORE any other data (basically putting in it A1, "pushing" the existing data there down below the new copied data), instead of putting it to the end. I have a code for copying and putting the data into the end of "Chain" sheet.
Sub CopyRange()
Dim x, y(), I As Long, ii As Long
If Sheets("Nastavit D").[Q2] = "" Then Exit Sub
x = Sheets("Nastavit D").[Q2:R1000]
For I = 1 To UBound(x, 1)
If x(I, 1) <> "" Then
ReDim Preserve y(1 To 2, 1 To I)
For ii = 1 To 2
y(ii, I) = x(I, ii)
Next
Else: Exit For
End If
Next
With Sheets("Chain")
.Cells(.rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(y, 2), 2) = Application.Transpose(y)
End With
End Sub
EDIT:
I started to rewrite the whole VBA code based on suggestions by #BigBen and #Jeff. However, for now, it copies the whole range of Q2:R1000, even blank cells, because they contain formulas I think. How can I copy only cells with actual values, even if it contains formulas?
Sub CopyRangeUpdated()
Dim lastRow As Long
lastRow = Sheets("Chain").Range("A65536").End(xlUp).Row + 1
If Sheets("Nastavit D").[Q2] = "" Then Exit Sub
Sheets("Nastavit D").Range("Q2:R1000").Copy
Sheets("Chain").Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True
'clear clipboard
Application.CutCopyMode = False
End Sub
Here is a sample code for #BigBen's suggestion
Edited in response to question edit
The skip blanks not compress what is copied to remove blanks, it will just "skip over" them. for example:
1 A
_ B
3 C
pasting col1 onto col2 will result in:
1
B
3
'copy range
Sheets("Nastavit D").Range("Q2:R1000").Copy
'paste values
Sheets("Chain").Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
'clear clipboard
Application.CutCopyMode = False
'copy formatting
Sheets("Nastavit D").Range("Q2:R1000").Copy
'paste formatting
Sheets("Chain").Range("A1").PasteSpecial xlPasteFormats
To "push data down", I would insert cells beforehand:
Sheets("Chain").Rows("2:1001").insert Shift:=xlDown
Then delete blank rows with something like this (the i is there to prevent an infinite loop if the last row is blank)
i=2
for x = 2 to 1001
if i<10001 then
if sheet("Chain").Range("A"&x).text = "" then
Sheet("Chain").Range("A"&x).entirerow.delete xlshiftup
'if say row2 is deleted, need to re-check row2 new value
x = x-1
end if
else
exit for
end if
i=i+1
next x
I am trying to copy all rows from an excel sheet Sheet1 that have a specific value in column A and B. and then paste them into a new sheet Sheet2. My specific example is I have figured out that I want to copy the rows that have a 0 in Column A as well as 4000 in Column B.
The problem that I am having is that the code copies all rows that have a 0 in column A not just the ones that meet both conditions.
My code is below for reference:
Sub Temp_copy()
set i = Sheets("Sheet1")
set e = Sheets("Sheet2")
Dim d
Dim j
d = 1
j = 2
Do Until IsEmpty(i.Range("A" & j))
If i.Range("A"&j) = Range("B6"&j) And i.Range("B" & j) = Range(B"10"&j) Then
d=d+1
e.Rows(d).Value=i.Rows(j).Value
End If
j = j+1
Loop
End Sub
Hopefully that makes sense. I am new to VBA so any help or guidance to achieve what I need would be muchly appreciated.
you can use AutoFilter() method of Range object, as follows (explanations in comments):
Sub foo()
Dim wsResult As Worksheet
Set wsResult = Sheets("Sheet02")
With Worksheets("Sheet01")
With .Range("A2:B" & .Cells(.Rows.Count, "A").End(xlUp).Row) 'reference its columns A:B cells from row 2 (header) down to last not empty one in column "A" (If you need to copy more columns than simply adjust "A2:B" to whatever columns range you need)
.AutoFilter field:=1, Criteria1:="0" ' filter referenced cells on 1st column with "0" content
.AutoFilter field:=2, Criteria1:="4000" ' filter referenced cells on 2nd column with "4000" content
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=wsResult.Range("A1") ' if any filtered cell other than the header then copy their first five columns and paste to 'wsResult' sheet starting from its column A last not empty cell
End With
.AutoFilterMode = False
End With
End Sub
Try this:
Sub Temp_Copy()
Dim cl As Range, rw As Integer
rw = 1
For Each cl In Worksheets("Sheet1").Range("A1:A10") //Set range as needed
If cl = 0 And cl.Offset(0, 1) = 4000 Then
cl.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & rw)
rw = rw + 1
End If
Next cl
End Sub
I want to delete the entire rows for cell that contain 'Total' and 'Nett' in column C.
I have tried the macro recording using Auto Filter but it only delete rows up to a specified range (which may differ if I use other set of data).
Appreciate your help!
Here you go. Just copy and paste this sub into your file. To use it, select the SINGLE column that you want to evaluate. This will go through every cell that has been selected, and if it matches the criteria, it will delete the entire row. Let me know if you have any questions. Good luck!
Sub DeleteRows()
'Enter the text you want to use for your criteria
Const DELETE_CRITERIA = "Test"
Dim myCell As Range
Dim numRows As Long, Counter As Long, r As Long
'Make sure that we've only selected a single column
If Selection.Columns.Count > 1 Then
MsgBox ("This only works for a single row or a single column. Try again.")
Exit Sub
End If
numRows = Selection.Rows.Count - 1
ReDim arrCells(0 To 1, 0 To numRows) As Variant
'Store data in array for ease of knowing what to delete
Counter = 0
For Each myCell In Selection
arrCells(0, Counter) = myCell
arrCells(1, Counter) = myCell.Row
Counter = Counter + 1
Next myCell
'Loop backwards through array and delete row as you go
For r = numRows To 0 Step -1
If InStr(1, UCase(arrCells(0, r)), UCase(DELETE_CRITERIA)) > 0 Then
Rows(arrCells(1, r)).EntireRow.Delete
End If
Next r
End Sub
This will loop through cells in Column C and delete the entire row if the cell contains either "Total" or "Nett". Keep in mind that it is case sensitive, so the first letter of "Nett" or "Total" would need to be capitalized for this to find it. There can be other text in the cell however. Also note that the references are not fully qualified (ie Workbook().Worksheet().Range()) because you did not provide a workbook or worksheet name. Let me know if this does not work for you.
Sub Delete()
Dim i as Integer
For i = Range("c" & Rows.Count).End(xlUp).Row To 1 Step -1
If Instr(1, Cells(i, 3), "Total") <> 0 Or Instr(1, Cells(i,3),"Nett") <> 0 Then
Cells(i,3).EntireRow.Delete
End If
Next i
End Sub
Hello and first let me say thank you!
I use Excel to capture user requirements and descriptions. I then take that information and clean it up and paste into presentation docs, apply formatting, paste into Powerpoint, etc. It can be 100s of lines in total that this is done for. What I'm looking for is a macro that I can apply to data once it is pasted into Excel. The data will be text, non-numeric
I have a macro that I use to insert a blank row as every other row. I then do everything else manually (macro shown below).
What I'm looking for is a macro that inserts a blank row, then offsets Column 2 by 1 row down. then pastes column 1 into column 2(without copying the blank cells over my already existing data in column 2).
I've pasted a link to an image of what I'm looking for. I've also tried to show below (numbers are column 1, letters are column 2).
2 columns to 1 column - desired result
1 A 2 B3 C
Result I want:
1
A
2
B
3
C
My current "Blank Row" Macro:
Sub insertrow()
' insertrow Macro
Application.ScreenUpdating = True
Dim count As Integer
Dim X As Integer
For count = 1 To 300
If ActiveCell.Value <> "" Then
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(0, 0)).EntireRow.Insert
ActiveCell.Offset(1, 0).Select
For X = 1 To 1
Next X
Else
ActiveCell.Offset(1, 0).Range("a1").Select
End If
Next count
End Sub
This should work, but you'll have to adjust a little for your exact layout and needs.
Sub mergeColumns()
Dim mergedData As Variant
ReDim mergedData(1 To 600)
dataToProcess = Range("A2:B301")
For i = 1 To 300
mergedData(i * 2 - 1) = dataToProcess(i, 1)
mergedData(i * 2) = dataToProcess(i, 2)
Next i
Range("B2:B601") = WorksheetFunction.Transpose(mergedData)
End Sub
The following does what you need without inserting blank rows. It also calculates what the last row is on the sheet that has 2 columns so that you don't need to hard-code when the loop will end.
The comments should help you understand what is happening each step of the way. You can then modify this to work with your particular workbook. There are a lot of ways you could go about this. I chose to put the pivoted result on a second sheet.
Sub PivotTwoColumnsIntoOne()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim rng As Range
Dim cell As Range
Dim lastRow As Long
Dim targetRow As Long
Set wb = ThisWorkbook
' set our source worksheet
Set src = wb.Sheets("Sheet1")
' set our target sheet (where the single column will be)
Set tgt = wb.Sheets("Sheet2")
' get the last row on our target sheet
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
' set the starting point for our target sheet
targetRow = 1
Set rng = src.Range("A1:A" & lastRow)
For Each cell In rng
With tgt.Range("A" & targetRow)
' get the value from the first column
.Value = cell.Value
' get the value from the second column
.Offset(1).Value = cell.Offset(, 1).Value
.HorizontalAlignment = xlLeft
End With
targetRow = targetRow + 2
Next cell
End Sub
Basically I have the following scenareo:
2 columns, with 600 rows of data.
I need to copy the data from column 2 and place it at the end of the content in column1 for the same rows. This would result in column 1 having its original content plus the additional content of column 2.
Any information in how I can do this will be greatly appreciated.
Thanks in advance!
Here's a VBA in a simple form. Just create a macro, add these lines to it. Then select your original column (what you're calling column 1), and run the macro.
a = ActiveCell.Value
b = ActiveCell(1, 2).Value
ActiveCell.Value = a + b
The bracketed cell reference is a relative statement - 1, 2 means "same row, one column to the right" so you can change that if you need. You could make it loop by expanding thusly:
Do
a = ActiveCell.Value
b = ActiveCell(1, 2).Value
ActiveCell.Value = a + b
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
Exit Do
End If
Loop
That loop will carry on until it finds a blank cell, then it'll stop. So make sure you have a blank cell where you want to stop. You could also add extra characters into the line that combines.. so in the above example it's ActiveCell.Value = a + b, but you could make it ActiveCell.Value = a + " - " + b or anything else that may help.
This should take the values from column 2 and place them sequentially at the bottom of column 1.
Sub test()
Dim rng1 As Range
Dim rng2 As Range
Dim cl As Range
Dim r As Long
Set rng1 = Range("A1", Range("A1048576").End(xlUp))
Set rng2 = Range("B1", Range("B1048576").End(xlUp))
r = rng1.Rows.Count + 1
For Each cl In rng2
Cells(r, 1).Value = cl.Value
r = r + 1
Next
End Sub
Just keep it simple. Here is the code.
Sub copyCol()
Dim lastRow As Long
lastRow = Range("A65000").End(xlUp).Row
Range("B1:B" & lasrow).Copy Range("A" & lastRow).Offset(1, 0)
End Sub
As this question received a number of views (10,000+) I thought it was important to also share another and far simpler solution:
In cell C1 use the formula:
=(A1 & B1)
This will copy the content of cell A1 and B1 into cell C1. Drag the formula to all other rows (row 600 in my case).
Then copy the column and paste using 'values only'.
You will then have cells in column C containing the content of column A and column B in a single cell on a row-to-row basis.