I have problem on swapping Column A to Column B then Column B to Column A, both column has row count of 2563. Is there any vba code to solve this problem?
I'm Already trying this code:
Private Sub CommandButton1_Click()
Dim temp As Double
temp = Range("A1").Value
Range("A1").Value = Range("B1").Value
Range("B1").Value = temp
End Sub
But it can only swap row 1 of both columns...
You can swap them all by a loop. For your case, the loop should go for 2563 times.
Private Sub CommandButton1_Click()
For i = 1 To 2563
temp = Cells(i, 1).Value
Cells(i, 1).Value = Cells(i, 2).Value
Cells(i, 2).Value = temp
Next i
End Sub
Using an array would be much faster than looping. In this example column A is copied into an array Hold_RNG. Then Column B is copied to column A, and then the Array is copied into Column B.
Sub SwapCOlumns()
Dim hold_rng() As Variant
Dim rowsToinclude As Long, WS As Worksheet
Set WS = ActiveSheet '<--- make sure this is correct worksheet
rowsToinclude = 2563 '<----- might want to make more dynamic
With WS
hold_rng = .Range("A1:A" & rowsToinclude)
.Range("A1:A" & rowsToinclude).Value = .Range("B1:B" & rowsToinclude).Value
.Range("B1:B" & rowsToinclude).Value = hold_rng
End With
End Sub
Updated: I don't mean to pick on the competing answer as it's simple and effective, but our two answers offer a good illustration of why using Arrays to impact a spreadsheet all at once, is much more efficient than looping and editing. I built this code which will time the results of each approach (inserting in Column E) of a spreadsheet. Through one round of 2563 rows the score was 0 seconds to 4. The array continued to output in 0 seconds while the loop approach fell to 41 seconds when doing 9 trials.
Screen Shot Of Results.
Timing code can be found on my PasteBin page (I don't want this answer to look ridiculously long)
I prefer to use arrays because is much faster.
Option Explicit
Sub test()
Dim i As Long
Dim arrA As Variant, arrB As Variant
Dim ValueA As Double, ValueB As Double
'Cahng if needed
With ThisWorkbook.Worksheets("Sheet1")
arrA = .Range("A1:A2563")
arrB = .Range("B1:B2563")
For i = 1 To 2563
ValueA = arrA(i, 1)
ValueB = arrB(i, 1)
arrA(i, 1) = ValueB
arrB(i, 1) = ValueA
Next i
.Range("A1").Resize(UBound(arrA), 1) = arrA
.Range("B1").Resize(UBound(arrB), 1) = arrB
End With
End Sub
Just to add it into the mix, there is a third way.
Insert a column after B. Copy A to C. Delete A.
With ThisWorkbook.Worksheets(1)
.Columns(3).Insert
.Columns(1).Copy .Columns(3)
.Columns(1).Delete
End With
(It assumes you want to move the whole column, but you normally would.)
However, the speed at which this will run depends upon the size of the worksheet and how many formulae it has.
Related
I have a set of information in the same column (H27:O27) in one sheet ("P1-FR1") and would like to paste individual values to another sheet (AQ6:AX6) ("Übersicht GESAMT")
I'm trying to use a For loop but the values just copy one after the other (in the same cell) instead of copying one in each cell. This is my code:
Sub CopyValues()
Dim i As Long
Dim j As Long
Dim Wert As Long
For i = 8 To 14
Wert = Sheets("P1-FR1").Cells(27, i)
For j = 43 To 50
Sheets("Übersicht GESAMT").Cells(6, j) = Wert
Next j
Next i
End Sub
You don't need a double For loop in this case at all. A simple .Value copy will work. The code below shows two examples with different ways to accomplish what you want. (TIP: it always helps me to be VERY clear on how I name the variables, it helps to keep track of where all the data is coming and going)
Option Explicit
Sub CopyTheValues()
Dim datenQuelle As Range
Dim datenZiel As Range
Set datenQuelle = ThisWorkbook.Sheets("P1-FR1").Range("H27:O27")
Set datenZiel = ThisWorkbook.Sheets("Übersicht GESAMT").Range("AQ6:AX6")
'--- method 1 - works because the ranges are the same size and shape
datenZiel.Value = datenQuelle.Value
'--- method 2 - for loops
' index starts at 1 because the Range is defined above
' (and we don't care what rows/columns are used)
Dim j As Long
For j = 1 To datenQuelle.Columns.Count
datenZiel.Cells(1, j).Value = datenQuelle.Cells(1, j).Value
Next i
End Sub
Copying By Assignment
Option Explicit
Sub CopyValuesNoLoop()
ThisWorkbook.Worksheets("Übersicht GESAMT").Range("AQ6:AX6").Value _
= ThisWorkbook.Worksheets("P1-FR1").Range("H27:O27").Value
End Sub
Sub CopyValuesQuickFix()
Dim j As Long: j = 43
Dim i As Long
For i = 8 To 14
ThisWorkbook.Worksheets("Übersicht GESAMT").Cells(6, j).Value _
= ThisWorkbook.Worksheets("P1-FR1").Cells(27, i).Value
j = j + 1
Next i
End Sub
The nesting of the for loops is causing your issue. It is causing each cell from the first sheet to be copied to all cells on the second sheet.
You only need one loop to perform the copy. Something like this should work.
Sub CopyValues()
Dim i As Long
For i = 8 To 15
Sheets("Übersicht GESAMT").Cells(6,i+35) = Sheets("P1-FR1").Cells(27,i)
Next i
End Sub
I am looking to search the text in first column for specific words and when they're found copy and paste the adjacent column to somewhere else.
I've got this code which works fine if the text is exactly those words but if anything else is there it fails (i.e super consolidator).
I'm still very new to VBA and have just adapted some other code to get to this point. I figure the find function would be a good way to go about it but I can't wrap my head around how to avoid the infinite loops. Any help here would be appreciated
Sub Test()
Dim lr As Long
Dim r As Long
' Find last row in column A with data
lr = Cells(Rows.Count, "A").End(xlUp).Row
' Loop through all rows in column A
For r = 1 To lr
' Check value on entry
If (Cells(r, "A") = "Super") Or (Cells(r, "A") = "Pension") Or (Cells(r, "A") = "SMSF") Then
' Copy column B and paste in C where found
Cells(r, "B").Select
Selection.Copy
ActiveCell.Offset(0, 1).PasteSpecial
End If
Next r
End Sub
What you're looking for is called Wildcard string comparision. And you can use VBA's Like operator to achieve your output
If (Cells(r, "A") Like "Super*") Or (Cells(r, "A") Like "Pension*") Or (Cells(r, "A") Like "SMSF*") Then
Here the * in Super* means that the text should start with "Super" and it can have anything after that.
If you'd like to search if the cell contains "Super" anywhere, you can use *Super* - * at both ends of Super
To have a more robust code I moved the "signal" words you are checking for into an array at the beginning of the sub.
Same with the column indexes of the column you want to copy and the target index.
By that it is much easier to make adjustments if the requirements change, e.g. look for a forth word etc.
Furthermore you should avoid implicit referencing cells. That's why I added the ws-variable - you have to adjust your sheet name.
Plus I added a generic function isInArray that takes the cell-value plus the array with the lookup values and returns true or false. Here the like-operator is implemented.
You don't need to select-copy/paste the values - you can simply write them to the target cell: .Cells(r, targetColumnIndex).value = .Cells(r, sourceColumnIndex).value.
But be aware: if you have a lot of data it would make more sense to load everything into an array and work on that ... but that's the next lesson to learn ;-)
Option Explicit
Public Sub copyValues()
Dim arrLookupValues(2) As Variant
arrLookupValues(0) = "Super"
arrLookupValues(1) = "Pension"
arrLookupValues(2) = "SMSF"
Const sourceColumnIndex As Long = 2 'take value from column B
Const targetColumnIndex As Long = 3 'write value to colum C
application.screenupdating = false
Dim lr As Long
Dim r As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'adjust this to your needs
With ws
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
For r = 1 To lr
' Check value on entry
If isInArray(.Cells(r, 1).value, arrLookupValues) Then
' write value of column B (2) to C (3)
.Cells(r, targetColumnIndex).value = .Cells(r, sourceColumnIndex).value
End If
Next r
End With
application.screenupdating = true
End Sub
Private Function isInArray(value As Variant, arrLookFor As Variant) As Boolean
Dim i As Long
For i = LBound(arrLookFor) To UBound(arrLookFor)
If value like arrLookFor(i) & "*" Then
isInArray = True
Exit For
End If
Next
End Function
First time using the site as I am new to VBA, but I am trying to write a piece of code that will look through a column of my choice, in this case column A, and go through each row and delete empty rows until the end of the dataset. I was thinking of doing a loop where I would reference the first cell in my dataset A1 and set the row number as a integer which would increase by 1 with each completion of the loop.
Private Sub CommandButton1_Click()
Dim X as Integer
Set X = 1
For X = 1 to 100
If Sheet1.Range("A":X).Value = "" Then Rows(X).EntireRow.Delete
Next X
End Sub
Thanks for any help or insights you can provide!
You want to concatenate in Range("A":X) so change : to & (or use cells).
When deleting rows you should step backwards or create a unionized range otherwise you will skip a row with every deletion you perform.
You don't want to set integers that is only for objects. There is also no benefit from using integer over long in VBA so best to just always use long as integer can give overflow errors in very large spreadsheets.
Rows(X).EntireRow.Delete is using a relative reference not an explicit one, use a with or explicitly reference every range object.
You are immediately overwriting X with the loop so you don't need to assign it a value before the loop.
Here's some code that will do what you need:
Dim lastrow As Long
Dim x As Long
With Sheet1
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For x = lastrow To 1 Step -1
If .Cells(x, 1).Value = "" Then
.Rows(x).EntireRow.Delete
End If
Next x
End With
You are missing your "End if". Also when looping through a range and deleting rows you need to loop bottom up because when a row is deleted it does not recalculate the range.
Sub CommandButton1_Click()
Dim x As Long
Dim lastrow As Long
lastrow = Range("A1" & Rows.Count).End(xlUp).Row
For x = lastrow To 1 Step -1
If Worksheets(1).Range("A" & x).Value = "" Then
Worksheets(1).Range("A" & x).EntireRow.Delete
End If
Next x
End Sub
I want to delete entire rows of data, if the formula matches the set value.
I am running a check (example: sum of three columns = 0?) through a set of 17K records. The code takes around 20 minutes to complete.
Dim currentRow As Integer
Dim rowCheck As Long
Dim ws As Worksheet
Set ws = ActiveSheet
For currentRow = ws.UsedRange.Rows.Count To 2 Step -1
rowCheck = Application.WorksheetFunction.Sum(Cells(currentRow, 5), Cells(currentRow, 6), Cells(currentRow, 7))
Select Case rowCheck
Case 0
ws.Rows(currentRow).Delete ' it takes around 20 minutes to complete with 17K records to run through
Case Else
End Select
Next
Set ws = Nothing
The code is working, however, it seems, I am doing something wrong, as I believe the code should work so much faster with given set of data (only 17K records).
Is there a way to optimize the deletion line?
Having to go through it line for line isn't the fast way to do this. You would be better off with a temporary helper column which calculates the sum. You can then filter the range on this column and delete all rows that match your criteria at once. So something like this. (assuming Column H is empty)
Dim currentRow As Integer
Dim rowCheck As Long
Dim ws As Worksheet
Dim lastRow as integer
Set ws = ActiveSheet
lastRow = ws.UsedRange.Rows.Count
ws.range("h2").formula = "=sum(e2:g2)"
ws.range("h2").autofill destination:= ws.range("h2:h" & lastRow)
ws.range("a1:h1").autofilter field:=8, criteria1:="0"
ws.range("a2:h" & lastRow).SpecialCells(xlCellTypeVisible).entirerow.delete
ws.autofiltermode = false
ws.range("h1:h" & lastRow).clearcontents
set ws = Nothing
Edit: You could also filter columns E, F, and G on 0 but that only works if all values are 0 or positive. Doing it the way I suggested gives you more control, because you can easily adjust the formula you put in cell H2.
It will be much faster to find all the rows that you want to delete, select all the rows, and delete them in one go, instead of doing it row by row.
let's say you found you wanted to delete rows 35, 37, 39, and 40 then the code will be something like
for each row in row_to_evaluate
delete_row = evaluate(row)
if delete_row = True then Delete_Row_List = Delete_Row_List & "," & row
next
'Example: Delete_Row_List = "35,37,39,40"
Rows(Delete_Row_List).Delete Shift:=xlUp
also remember application.screenupdating = False before you run the code and application.screenupdating = True after you run it for a bit better performance.
hope it helps
EDIT:
Ah I see an answer before mine basically recommended the same
It just occurred to me to speed up your code substantially. I assumed that you have to use the delete rows capability, but it will actually be much faster to do the following (note this is pseudo code, panel beat to work for you):
with thisworkbook.worksheets("Sheet1")
redim New_Sheet(1 to nr_rows, 1 to nr_columns) as variant
Old_Sheet = .range(.cells(1,1),.cells(nr_rows,nr_columns)
'keep the headers
for col = 1 to nr_columns
New_Sheet(1,col) = Old_Sheet(1,col)
next col
k = 1
for row = 2 to nr_rows 'start at 2 to protect the headers
keep_row = evaluate_row(row,Old_sheet) 'this function must evaluate the row. return True if you want to keep the row, return false if you want to delete it
if keep_row then
k = k+1
for col = 1 to nr_col
New_sheet(k,col) = Old_Sheet(row,col)
next col
next row
.range(.cells(1,1),.cells(nr_rows,nr_columns) = New_Sheet
end with
I have been trying to find something that can help me online but no luck. I am trying to compare a value in column A with a value in Cell E1 and if match I want to put an X in column B next to the match in Column A.
here is my code I go so far:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim a As Integer
Dim i As Integer
Dim x As Range
Dim y As Range
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
i = Worksheets("Sheet1").Range("E1")
x = Worksheets("Sheet1").Range("B1:a")
y = Worksheets("Sheet1").Range("A1:a")
'For Each cell In y
'if y = i then
'print "X" in column B next to the value
'MsgBox (i)
End Sub
thanks for your help in advance
Dan
There are a few things here that are worth mentioning. When you want to specify a range using .Range you have to specify the columns on both sides of the : ; furthermore, it takes a string. This means that what you're passing is "B1:a" which doesn't make sense to the computer because it doesn't know you want it to use the value of a instead of the letter. You need to pass "B1:B" & a to the .Range. What this does is concatenate the value you found in the variable a to the string so it appears as one string to the computer.
I personally think it's easier to take all of the values as a column vector instead of dimming the x's as a range because it makes the iteration a little easier. Instead of keeping track of what row I'm on, Counter will always tell me where I am since I'm just moving down a single column. As an added bonus, this reduces the times you access the worksheet which helps speed up your macro.
Although it's commented out, it's worth noting that the loop at the bottom of your sub wouldn't work because you haven't properly closed off the if or the for.
I'm not sure what you intended this for, but it's never a bad idea to use meaningful names so you can look back on your code and figure it out without too much effort. For example, I've renamed your a variable to lastrow which at a glance describes what value it stores.
Below your code that I've altered
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lastrow As Long
Dim Criteria As Long
Dim x() As Variant
Dim Counter As Long
lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Criteria = Worksheets("Sheet1").Range("E1").Value
x = Worksheets("Sheet1").Range("B1:B" & lastrow).value
For Counter = 1 To UBound(x)
If x(Counter,1) = Criteria Then
Worksheets("Sheet1").Cells(Counter, "B").Value = "X"
End If
Next Counter
MsgBox (Criteria)
End Sub
I little bit different approach. This find the last row in column A.
I also included if you want to match by wildcard, i.e. you want to find 45 in 645.
Sub Worksheet_SelectionChange()
Dim lrow As Integer
Dim a As Integer
Dim i As String
Dim Val As String
lrow = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row 'Find last row
i = Worksheets("Sheet1").Range("E1") 'Set cell where compare value is
For a = 1 To lrow 'Loop from row 1 to last row in column A
Val = Cells(a, "A").Value 'Set value to compare in Column A
'If Val Like "*" & i & "*" Then 'Use this if you want to find 45 in 645, so wildcard
If Val = i Then 'Exact match
Cells(a, "B").Value = "X" 'Put X in column B
End If
Next a
MsgBox "Match Criteria: " & (i)
End Sub