I have a problem with looping a Macro in excel.
I have a Data base where i need to add a row above each unique value and copy the value below into the new row.
untill now i have come up with this:
Sub Test()
'
' Sneltoets: Ctrl+K
' FindNextValueChangeInColumn Macro
'
Dim currentValue As String
Dim compareValue As String
currentValue = ActiveCell.Value
If (currentValue = "") Then
Selection.End(xlDown).Select
Else
ActiveCell.Offset(1, 0).Select
compareValue = ActiveCell.Value
Do While currentValue = compareValue
ActiveCell.Offset(1, 0).Select
compareValue = ActiveCell.Value
Loop
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(1, 0).Select
Selection.Copy
ActiveCell.Offset(-1, 0).Select
Selection.PasteSpecial
End If
Exit Sub
End Sub
This macro does the job, but i dont want to press ctrl-k 4000 times every time an update is necessary. Anyone knows how to loop this macro ?
Just wrap a for loop around the code you want executed:
Sub Test()
'
' Sneltoets: Ctrl+K
' FindNextValueChangeInColumn Macro
'
'-------Loop from 1 to 4000------------
Dim loopy
For loopy = 1 to 4000 'Loop 4000 times
'--------------------------------------
Dim currentValue As String
Dim compareValue As String
currentValue = ActiveCell.Value
If (currentValue = "") Then
Selection.End(xlDown).Select
Else
ActiveCell.Offset(1, 0).Select
compareValue = ActiveCell.Value
Do While currentValue = compareValue
ActiveCell.Offset(1, 0).Select
compareValue = ActiveCell.Value
Loop
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(1, 0).Select
Selection.Copy
ActiveCell.Offset(-1, 0).Select
Selection.PasteSpecial
End If
'-----Don't forget this line-----
Next loopy
'--------------------------------
Exit Sub
End Sub
Alternatively, you can use a while loop to loop until the currentValue = "":
Do
currentValue = ActiveCell.Value
If (currentValue = "") Then
Selection.End(xlDown).Select
Else
ActiveCell.Offset(1, 0).Select
compareValue = ActiveCell.Value
Do While currentValue = compareValue
ActiveCell.Offset(1, 0).Select
compareValue = ActiveCell.Value
Loop
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(1, 0).Select
Selection.Copy
ActiveCell.Offset(-1, 0).Select
Selection.PasteSpecial
End If
Loop While currentValue <> ""
Related
Please suggest a vb code, that if the text box is left blank,and during TAB/Enter, the Error message box appears for each text box.
Private Sub CommandButton1_Click()
Sheets("Attendance").Select
Range("a1").Select
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.Value = Me.d.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.N.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.Salary.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.Remarks.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.IT.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.Outtime.Value
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Me.Lunch.Value
ActiveCell.Offset(0, 3).Select
ActiveCell.Value = Me.Advance.Value
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = Me.Paid.Value
End Sub
Please see below sub carefully and try to do to your user form.
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Me.TextBox1 = "" Then
MsgBox "You must enter value!"
Cancel = True
Me.TextBox1.SetFocus
End If
End Sub
I'm having a bit of trouble with any kind of paste method I use at the moment.
Data from one sheet must be cut and pasted to another, but I'm not sure what I'm missing.
The error occurs here, shortly after the commented "HERE" :
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Full code can be found below, thanks for any replies.
Option Explicit
Public Sub Workbook_Open()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb As Variant
Dim wsName As Variant
Dim blastrow As Variant
Dim flastrow As Variant
Dim lastrow As Variant
ActiveWorkbook.Sheets("combined").Select
Range("A1:U9999").ClearContents
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("G:\BS\Josh Whitfield\Credit_Chasing\NEW PROCESS\")
'file level loop
While (file <> "")
If InStr(file, ".xlsx") > 0 Then
Workbooks.Open "G:\BS\Josh Whitfield\Credit_Chasing\NEW PROCESS\" & file
wb = ActiveWorkbook.Name
'ws = ActiveSheet.Name
Dim ws As Worksheet
'worksheet/tab level loop
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
wsName = ws.Name
'andrew code (09/12/2015)
blastrow = Workbooks("Copy of merge.xlsb").Worksheets("Combined").Range("A" & Rows.Count).End(xlUp).Row + 1
If blastrow = 2 Then blastrow = 1
Workbooks("Copy of merge.xlsb").Worksheets("Combined").Range("A" & blastrow & ":XFD" & blastrow).Value = _
Workbooks(wb).Worksheets(wsName).Range("A1:XFD1").Value
lastrow = Range("A" & Rows.Count).End(xlUp).Row
'finding status column
Range("M1").Select
Do Until ActiveCell.Value = "Status" Or ActiveCell.Column > 100
If Range("A2") = "" Then
GoTo there
End If
ActiveCell.Offset(0, 1).Select
Loop
'looping through
Do Until ActiveCell.Row > lastrow
If ActiveCell.Value = "Solved" Then 'HERE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
wb = ActiveWorkbook.Name
wb = Replace(wb, ".xlsx", "")
ActiveCell.EntireRow.Cut
Workbooks("copy of merge.xlsb").Activate
'find matching company
Range("E1").Select
While ActiveCell.Value <> "CoName"
ActiveCell.Offset(0, 1).Select
Wend
Do Until ActiveCell.Value = wb
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
ActiveCell.EntireRow.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Loop
'first cell in row select
ActiveSheet.Cells(ActiveCell.Row, 1).Select
'find matching ws
If ws = "Be Wiser" Then
Do Until ActiveCell.Value = "BW"
ActiveCell.Offset(1, 0).Select
Loop
ElseIf ws = "Insure Wiser" Then
Do Until ActiveCell.Value = "IW"
ActiveCell.Offset(1, 0).Select
Loop
ElseIf ws = "Call Wiser" Then
Do Until ActiveCell.Value = "CW"
ActiveCell.Offset(1, 0).Select
Loop
ElseIf ws = "Quote Wiser" Then
Do Until ActiveCell.Value = "QW"
ActiveCell.Offset(1, 0).Select
Loop
ElseIf ws = "Be Wiser Business" Then
Do Until ActiveCell.Value = "BWB"
ActiveCell.Offset(1, 0).Select
Loop
ElseIf ws = "Younger But Wiser" Then
Do Until ActiveCell.Value = "YBW"
ActiveCell.Offset(1, 0).Select
Loop
End If
'insert row and paste
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'lastrow = Range("A" & Rows.Count).End(xlUp).Row + 1
'Range("A" & lastrow).Select
'ActiveSheet.Paste
ws.Activate
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Cells.Select
ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A2:A19" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
.SetRange Range("A1:U" & lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("M1").Select
Do Until ActiveCell.Value = "Status" Or ActiveCell.Column > 100
ActiveCell.Offset(0, 1).Select
Loop
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
there:
'here
flastrow = Workbooks("Copy of merge.xlsb").Worksheets("Combined").Range("A" & Rows.Count).End(xlUp).Row
If blastrow = flastrow Then
Workbooks("Copy of merge.xlsb").Worksheets("Combined").Activate
Range("A" & blastrow).Select
ActiveCell.EntireRow.Delete
Workbooks(wb).Worksheets(wsName).Activate
End If
Next ws
Workbooks(wb).Close False
End If
file = Dir
Wend
Call storeFileNames
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
As has been noted, you really ought to rewrite this, but as a quick fix, add a range variable:
Dim rgCut as Excel.Range
then instead of this:
ActiveCell.EntireRow.Cut
use:
set rgCut = ActiveCell.EntireRow
and then replace this:
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
with this:
rgCut.Cut Destination:=Selection.Cells(1)
The below code is automatically runs when a cell in a specified column changes and if it is not empty.
Sub mergeCells()
Dim num As Integer
Dim countmerged As Integer
If IsEmpty(ActiveCell.Value) Then
Exit Sub
Else
countmerged = -1
If ActiveCell.Offset(-1, 0).mergeCells Then
countmerged = ActiveCell.Offset(-1, 0).MergeArea.Cells.Count * -1
End If
num = ActiveCell.Offset(countmerged, -1).Value
If ActiveCell.Offset(countmerged, 0).Value = ActiveCell.Value Then
ActiveCell.ClearContents
ActiveCell.Offset(0, 1).ClearContents
ActiveCell.Offset(0, 37).ClearContents
ActiveCell.Offset(0, 36).ClearContents
ActiveCell.Offset(0, -1).ClearContents
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.Offset(2, 0).EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
Range(ActiveCell.Offset(countmerged, 37), ActiveCell.Offset(0, 37)).Merge
Range(ActiveCell.Offset(countmerged, 36), ActiveCell.Offset(0, 36)).Merge
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(countmerged, 1)).Merge
Range(ActiveCell.Offset(countmerged, -1), ActiveCell.Offset(0, -1)).Merge
Range(ActiveCell, ActiveCell.Offset(countmerged, 0)).Merge
ActiveCell.Offset(1, -1).Value = num + 1
ActiveCell.Offset(2, -1).Value = num + 2
Else
ActiveCell.Offset(1, 0).EntireRow.Insert
ActiveCell.Offset(2, 0).EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
Selection.Offset(1, -1).Value = num + 2
Selection.Offset(2, -1).Value = num + 3
End If
End If
End Sub
if the value is the same value with the above cell, they are being merged and another row with the same formulas is inserted. This works without problem.
But if the value is not the same as the above cell, only a row must be inserted with the same formulas but it adds rows without stopping.
I don't think you are showing us the important part of the code (that sets this one off).
I would try disabling events since the macro is likely changing a cell and seeing that a cell is changed (inserted, whatever) starting your event again.
Try adding these at the beginning and ending of your macro.
Application.EnableEvents = False
Application.EnableEvents = True
I need the macro to go down a column in Excel and run the TEST procedure until the cells are empty. The TEST procedure always ends with the cell you started with selected. Here is how it looks manually but I would like to code it to run on a loop until the cell in column "B" is empty. Thanks in advance for any help. Here is what I am doing now (without a loop):
Sub NotLooped()
Windows("Pattern Scanv4.xlsm").Activate
Sheets("DATA").Select
Range("B2").Select
Application.Run ("TEST")
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
'etc.................
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
If ActiveCell.Offset(1, 0).Value = 0 Then
ElseIf ActiveCell.Offset(1, 0).Value > 0 Then
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Run ("TEST")
End If
End Sub
Try this:
Sub Looped()
Dim sht As Worksheet, rng as Range
Set sht = Workbooks("Pattern Scanv4.xlsm").Sheets("DATA")
sht.Parent.Activate
sht.Select
Set rng = sht.Range("B2")
Do While Len(rng.value) > 0
rng.Select
TEST
Set rng = rng.offset(1,0)
Loop
End Sub
However it would be much better if your code didn't rely on a particular sheet being active or a given range being selected.
If you modify your TEST Sub to add a Range parameter then you can pass rng directly to it.
i.e. instead of:
Sub TEST()
...do something with selection/activecell
you can do this:
Sub TEST(rng As Range)
...do something with rng
and call it like this:
TEST rng
See How to avoid using Select in Excel VBA macros
I try to copy in the excel few rows to a table, and give the same auto number to the rowa I add in each opparation.
I have a macro that copy the rows and gives the first line (of the new lines I just added) the next auto number. I want to add the same number to the other rows. (and each time there can be different numbers of rows, but not more then 16).
my macro is:
Sub copy_order()
'
'
Sheets("orders").Select
Application.Goto Reference:="product"
ActiveCell.Range("A1:D16").Select
Selection.Copy
Application.Goto Reference:="orders_table"
Selection.End(xlDown).Select
ActiveCell.Offset(1, 1).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, -1).Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=R[-1]C+1"
ActiveCell.Offset(1, 0).Range("A1").Select
Application.Goto Reference:="product"
ActiveCell.Offset(0, 0).Range("A1:C1").Select
Selection.ClearContents
Application.Goto Reference:="orders_table"
End Sub
thank you, Keren.
Not sure I followed all your offsets correctly, but this should get you close...
Sub copy_order()
Dim rngDest As Range, rngCopy As Range, sht As Worksheet, num
Dim c As Range
Set sht = Sheets("orders")
Set rngCopy = sht.Range("product").Range("A1:D16")
Set rngDest = sht.Range("orders_table").Cells(1).End(xlDown).Offset(1, 0)
rngDest.Resize(rngCopy.Rows.Count, rngCopy.Columns.Count).Value = rngCopy.Value
num = rngDest.Offset(-1, -1).Value + 1
Do While Application.CountA(rngDest.Resize(1, rngCopy.Columns.Count)) > 0
rngDest.Offset(0, -1).Value = num
Set rngDest = rngDest.Offset(1, 0)
Loop
End Sub