I'm pretty new to VBA and having trouble creating a quick macro used to move blocks of numbers around.
What I am trying to create is a button that when pressed:
Moves the contents of (i,5) to E63
The cells from (i, 16) down to F67:F110
Dependant on whether Row 10 contains "Low" or "High" moves three cells from the set
N106:N109 to the cells (i12:i14) [Where i is the column reference).
The Range sections of code are what accomplish this and they are working fine, the problem I am having is with my Do.Until row and with the reference Column(i)
Does anyone know how this could work? Thanks
UPDATE
So thanks to the help of Siddharth I've been able to fix all but one bit, which is the lines where there is a string in the Range function. The reason I am not using .Formula here but Paste instead is that otherwise all of the cells A12:A14 to Z12:Z14 will equal the same thing which isn't correct. On the other parts that doesn't matter. I am getting a type 13 mismatch error on these lines.
Sub Columntest()
Dim i As Integer
i = 5
Do Until Cells(5, i).Value = ""
If Cells(10, i).Value = "Low" Then
Range("E63").Formula = Cells(5, i)
Range("F67:F110").Formula = Cells(16, i)
Range("O106:O108").Copy
Range("=" & Columns(i) & "12").PasteSpecial Paste:=xlPasteValues
End If
If Cells(10, i).Value = "High" Then
Range("E63").Formula = Cells(5, i)
Range("F67:F110").Formula = Cells(16, i)
Range("N106:N108").Copy
Range(Columns(i) & "12").PasteSpecial Paste:=xlPasteValues
End If
i = i + 1
Loop
End Sub
The type mismatch is because you are trying to concatenate a column object and a string in the range reference:
Range("=" & Columns(i) & "12").PasteSpecial Paste:=xlPasteValues
Try using this instead:
Cells(12, i).PasteSpecial Paste:=xlPasteValues
Related
I have some VBA code written that runs quite slowly. I have a series of different loops in my code. I know that loops aren't always the most efficient way to manipulate data, so I think they are the problem. I need ideas for how to either alter the loop or eliminate it so I can speed up the run time of my code.
Below is the most active loop I have created. It's running through all of the cells on row D (starting in D2) and manipulating their values based off of entries in the cells in row 1. If I can get help on this loop I'll probably be able to use similar techniques to alter the other loops in my code. Any tips are appreciated.
'sub work week for date range
Range("D2").Select
Do Until IsEmpty(ActiveCell.Value)
If IsEmpty(ActiveCell.Offset(-1, 0)) = False Then
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value & "-" & Right(ActiveCell.Value, 4)
Else: ActiveCell.Value = ActiveCell.Value & "-" & Right(ActiveCell.Offset(0, -1), 4)
End If
ActiveCell.Offset(0, 1).Select
Loop
The fastest, and more efficient method, would be as has been suggested in the comments by using arrays.
To get you to that point though, I've given you the first steps to improving your interaction with VBA and understanding how to write your code without selecting or activating objects:
For i = 4 To Cells(2, Columns.Count).End(xlToLeft).Column
With Cells(2, i)
If .Offset(-1, 0).Value = vbNullString Then
.Value = .Value & "-" & Right$(.Offset(0, -1).Value, 4)
Else
.Value = .Offset(-1, 0).Value & "-" & Right$(.Value, 4)
End If
End With
Next
Basically, you don't need to .Select or .Activate anything. Work with the objects directly and use a variable to dictate the column rather than activating the next cell.
Once you're comfortable with writing code in this style, look at assigning a range's value to a 2D array and then loop through the array instead.
For fast execution, my first recommendation is to turn automatic calculation and screen-updating off too if it still takes long.
I agree that anything that involves selecting is going to be incredibly slow so you should use range objects instead.
Final code:
' Declarations
Dim CurrentCell, LeftCell, PreviousCell As Range
Dim Last4Chars As String
'Initialize
Set CurrentCell = ActiveSheet.Range("D2")
'Optimizations
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Loop until Current Cell in Empty
Do Until IsEmpty(CurrentCell.Value)
Set AboveCell = CurrentCell.Offset(-1, 0) 'One row above
Set LeftCell = CurrentCell.Offset(0, -1) 'One column left
If IsEmpty(AboveCell) = False Then
CurrentCell.Value = AboveCell.Value & "-" & Right(CurrentCell.Value, 4)
Else
CurrentCell.Value = CurrentCell.Value & "-" & Right(LeftCell, 4)
End If
Set CurrentCell = CurrentCell.Offset(0, 1)
Loop
'Optimizations reversed for normal use
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I'm sorry but I asked this question already yesterday, but it seems like I wasn't clear enough with my wishes, so I try it again this time.
My code Looks like this right now:
If OptionButton11.Value = True Then
Set Rng = Sheets("Table").Range(TextBox3.Value & TextBox1.Value + 1 & ":" & TextBox3.Value & lastrow)
Set kst = Sheets("Table").Range(TextBox2.Value & TextBox1.Value + 1 & ":" & TextBox2.Value & lastrow)
For Each Cell In Rng
If Cell.Value = TextBox10.Value Then
Cell.copy Cell.Offset(, 1)
Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = kst.Value
End If
Next Cell
End If
In this scenario, the user has the opportunity to use textboxes to define where his values are in the worksheet and what the macro has to look for.
Textbox1.Value defines where the headings in the worksheet are.
`
Textbox2.Value defines where the value can be found
Textbox3.Value is the criteria after the value is filtered
And
Textbox.Value 4 is the required criteria.
I would like to achieve with this code; that whenever Textbox4.Value is found in the range of Textbox3.Value, TextBox2.Value and Textbox3.Value are copied into the first free columns in the worksheet.
My Problem right now is, that
Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = kst.Value
do not copy the values in the first empty column, but add them horizontally to each freely available row in a column.
I already tried it with xlDown instead of xlToLeft but then a runtimerror (1004) appears.
Has anyone a suggestion how to fix this?
Thank you.
I'm new to the community and I apologize if there is a thread elsewhere, but I could not find it!
I'm currently diving into VBA coding for the first time. I have a file that I dump into a worksheet that currently I'm manually organizing and pushing out. When put into the worksheet, it delimits itself across the cells. This dump file will have varying row and column lengths every time I get it in a given day and dump into a work sheet. For example, one day it may be twenty rows and one day it may be thirty.
A certain roadblock in my VBA code creation process has presented itself. I'm trying to create a code that will parse through the worksheet to remove any time a certain value appears (See below image - I'm referring to the (EXT)). After doing so I'm trying to concatenate the cells in the row up until there is a space (which with the rows that have (EXT), there usually isn't a space after until the (EXT) is removed).
The code I made works for now but I recognize it's not very efficient and not reliable if the names extend longer than two cells. I was hoping someone on here could provide me with guidance. So, I'm looking for two things:
For the code to scan the whole active used range of the table and remove (EXT). As it may appear in various columns.
A way to concatenate the cells in every row in the active range from A to the cell before a blank cell
Keep in mind I have no coding background, I'm learning and I'm not familiar with VBA terms and whatnot all that much just yet - so if you could please explain in laymen's terms I'd appreciate it. I hope all of this makes sense... Thanks in advance!
This is just an example of part of what the dump code looks like, so my code probably doesn't match with the example below - I just wanted to provide a visual:
http://i.imgur.com/IwDDoYd.jpg
The code I currently have:
Sub DN_ERROR_ORGANIZER()
' Removes any (EXT) in Column 3 in actual dump data file
For i = 200 To 1 Step -1
If (Cells(i, 3).value = "(EXT)") Then
Cells(i, 3).Delete Shift:=xlToLeft
End If
Next i
' Removes any (EXT) in Column 4 in actual dump data file
For j = 200 To 1 Step -1
If (Cells(j, 4).value = "(EXT)") Then
Cells(j, 4).Delete Shift:=xlToLeft
End If
Next j
' Removes any (EXT) in Column 5 in actual dump data file
For k = 200 To 1 Step -1
If (Cells(k, 5).value = "(EXT)") Then
Cells(k, 5).Delete Shift:=xlToLeft
End If
Next k
' Places a new column before A and performs a concatenate on cells B1 and C1 to
' form a name, then copies all through column A1 to repeat on each row
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "=PROPER(CONCATENATE(RC[1],"", "", RC[2]))"
Range("A1").Select
Selection.AutoFill Destination:=Range("A1:A51")
Range("A1:A51").Select
End Sub
edited: to keep the comma after the first "name" only
this should do:
Sub main()
Dim cell As Range
With Worksheets("names")
With Intersect(.UsedRange, .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).EntireRow)
For Each cell In .Rows
cell.Cells(1, 2).Value = Replace(Replace(Replace(Join(Application.Transpose(Application.Transpose(cell.Value)), " "), " ", " "), " (EXT)", ""), " ", ", ", , 1)
Next cell
.Columns(1).FormulaR1C1 = "=PROPER(RC[1])"
.Columns(1).Value = .Columns(1).Value
.Offset(, 1).Resize(, .Columns.Count - 1).ClearContents
End With
End With
End Sub
just remember to change "names" to you actual worksheet name
edited 2:
code for stopping cells to be processed at every line at the last one before the first blank one
Sub main()
Dim cell As Range, dataRng As Range
With Worksheets("names") '<--| change "names" to you actual worksheet name
Set dataRng = Intersect(.UsedRange, .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).EntireRow)
For Each cell In dataRng.Columns(1).Cells
cell.Offset(, 1).Value = Replace(Replace(Replace(Join(Application.Transpose(Application.Transpose(.Range(cell, cell.End(xlToRight)).Value)), " "), " ", " "), " (EXT)", ""), " ", ", ", , 1)
Next cell
With dataRng
.Columns(1).FormulaR1C1 = "=PROPER(RC[1])"
.Columns(1).Value = .Columns(1).Value
.Offset(, 1).Resize(, .Columns.Count - 1).ClearContents
End With
End With
End Sub
I believe you are quite close to achieve what you are asking for and, based on your request, I will not give you a solution but some guidance to complete it by yourself.
First 3 loops: You could simplify by having a single set of nested loops: An outer loop running from 3 to 5, an inner loop running from 200 to 1; the outer loop will run over index, say "p", the inner over index, say "q", and your reference to cells would become Cells(q,p). If you need to run this over more than 3 rows, just start the outer loop from, say, 3 and till, say 10000 (being 10000 the maximal number of rows your data may display) and add a condition that if the first cell of the row is empty, you exit the outer loop.
The second part (this is what I understood) is to take the 2-3 first cells and concatenate them into a new cell (i.e. the column you add at the left). Once again, you can just loop over all your rows (much the same as in the outer loop mentioned above), except that now you will be looking at the cells in columns 2-4 (because you added a column at the left). The same exit condition as above can be used.
I'm not sure if this is what you were looking for, but this is what I understood you were looking for.
After reading user3598756's answer, I realized that I missed the boat with my original answer.
Sub DN_ERROR_ORGANIZER()
Dim Target As Range
Set Target = Worksheets("Sheet1").UsedRange
Target.Replace "(EXT)", ""
With Target.Offset(0, Target.Columns.Count).Resize(, 1)
.FormulaR1C1 = "=PROPER(C1&"", ""&TEXTJOIN("" "",TRUE,RC[-" & (Target.Columns.Count - 1) & "]:RC[-1]))"
.Value = .Value
End With
Target.Delete
End Sub
UPDATE
If you are running an older version of Excel that doesn't support TEXTJOIN then use this:
Sub DN_ERROR_ORGANIZER()
Dim Data
Dim x As Long, y As Long
Dim Target As Range
Dim Text As String
Set Target = Worksheets("Sheet1").UsedRange
Target.Replace "(EXT)", ""
Data = Target.Value
For x = 1 To Target.Rows.Count
Data(x, 1) = Data(x, 1)
For y = 2 To Target.Columns.Count
If Data(x, y) <> vbNullString Then Text = Text & " " & Data(x, y)
Next
If Len(Text) Then Data(x, 1) = Data(x, 1) & "," & Text
Text = vbNullString
Next
Target.ClearContents
Target.Columns(1).Value = Data
End Sub
I am trying to calculate average, but i am getting an run-time error. Here is my code..
lastrowcell = Range("B1", Range("B1").End(xlDown)).Rows.Count
Range("F1").Value = "High+Low/2"
For n = 2 To lastrowcell
Range(Cells(n, 6)).Formula = "=average(" & Range(Cells(n, 2), Cells(n, 3)).Address(False, False) & ")"
Next
Can anyone show what I did wrong.
Thanks in advance...
You don't need to loop, Excel is smart enough to fill the entire thing in one go:
lastrowcell = Range("B1", Range("B1").End(xlDown)).Rows.Count
Range("F1").Value = "High+Low/2"
Range("F6:F" & LastRow).Formula = "=AVERAGE(B6:C6)"
The 6 will be incremented in each row
If you want the last row though, its always better to come from the bottom up unless you are specifically looking for the first blank:
lastrowcell = Range("B" & Rows.Count).end(xlup).row
Range(Cells(n, 6))
is not correct syntax for Range property. When there is only one parameter, it should be string. Instead you can use:
Cells(n, 6)
or
Range("F" & n).
has anyone had an issue in excel vba where a loop to copy and paste rows and check for certain criteria sometimes leaves out information and after i try to debug and run through it works fine
I have a loop
For rnum = 3 To LastRow
'if all cells are equal to the Comboboxes then copy and paste the row
ThisWorkbook.Activate
If Sheets("Revised Budget").Cells(rnum, 1).Value = BUval And _
Sheets("Revised Budget").Cells(rnum, 2).Value = TeamLocVal And _
Sheets("Revised Budget").Cells(rnum, 3).Value = YrVal And _
Sheets("Revised Budget").Cells(rnum, 9).Value = InstVal Then
Sheets("Revised Budget").Range(Cells(rnum, 1), Cells(rnum, 12)).Copy
NewWkbk.Sheets("Actual").Activate
If NewWkbk.Sheets("Actual").Range("A1").Offset(1, 0).Value = "" Then
NewWkbk.Sheets("Actual").Range("A1").Offset(1, 0).PasteSpecial
Else
NewWkbk.Sheets("Actual").Range("A1").End(xlDown).Offset(1, 0).PasteSpecial
End If
Application.CutCopyMode = False
End If
Next rnum
Are your variables strings or integers?
If any of them are strings you can try making sure it's not an issue with capitalization on your string matches.
ucase(Sheets("Revised Budget").Cells(rnum, 3).Value) = ucase(YrVal)
Consider updating all of your .value to .value2. I was running into a (potentially) similar issue, and that fixed it for me.
I think I may have figured it out through some more research. The page in which the macro was running through had data that was filtered. I put in a code that would ShowAllData and I believe that should fix the issue.