VBA XL 2010. Loop, define set of cells in a named column

[Ambre]

Hello everyone,

I am a begginer in VBA and had no real training so I am learning on my own by reading books and exploring forums.
I went through many posts in several forum and Microsoft websites in order to write the code I need but unsuccessfully.

What I am trying to do:
If the cells in column 1 (starting from row 15 and going down until an empty cell) are not empty, put "No" in cells in the column named "Savings" (starting from row 15). I do not want to write the column number because if the number of the column changes, the macro will not run anymore.

What I have written so far :

Option Explicit

Public Sub NoInCells()

Dim CelCount As Integer
CelCount = 15

Range("A15").Select
Do Until IsEmpty(ActiveCell)
'Find the column to write No
Dim column_criteria As Integer
For column_criteria = 1 To 200
If Worksheets("sheet1").Cells(11, column_criteria) = "Savings" Then
????(how to define the cells of the column named Savings)????.FormulaR1C1 = "No"
End If

ActiveCell.Offset(1, 0).Select

Next

CelCount = CelCount + 1

Loop

End Sub



Maybe I have some redundancies here.

Many thanks for your help.

I have other issues with other macros, should I create a post for each of them or write everything in the same?


Ambre
Excel 2010
Windows XP

 

[Ambre]

Here is the entire code. Does it make more sense ?
Everythink works fine otherwise. Only the last row added that has not the right serial number at the end.

[TABLE="width: 500"]
<TBODY>[TR]
[TD]Option Explicit

Public Sub copy_new_data()

'Add lines to PP
Sheets("Insert data Purchasing Plan").Select
'Finding the column number, in which copy criteria is found
Dim column_criteria As Integer
Dim Add_column As Integer

For column_criteria = 1 To 200
If Worksheets("Insert data Purchasing Plan").Cells(5, column_criteria) = "Project to be added Y/N" Then
Add_column = column_criteria
End If

Next

'Sort sheet, in order to eliminate empty rows between filled out rows

Rows("7:200").Select
ActiveWorkbook.Worksheets("Insert data Purchasing Plan").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Insert data Purchasing Plan").Sort.SortFields.Add _
Key:=Range("A7"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Insert data Purchasing Plan").Sort
.SetRange Range("A7:ED41")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply

End With

'To identify last row in source sheet:
Dim last_row_insert As String
Dim Doppelpunkt As String
last_row_insert = Range("A7").CurrentRegion.Address
Doppelpunkt = InStr(1, last_row_insert, ":")
Doppelpunkt = Doppelpunkt + 2
last_row_insert = Mid(last_row_insert, Doppelpunkt)
Doppelpunkt = InStr(1, last_row_insert, "$")
Doppelpunkt = Doppelpunkt + 1
last_row_insert = Mid(last_row_insert, Doppelpunkt)

' the last row to check, if it has be be copied : "last_row_insert"

Dim row_counter As Integer
row_counter = 7

'copy rows to PP

Do Until row_counter = last_row_insert + 1

If Worksheets("Insert data Purchasing Plan").Cells(row_counter, Add_column) = "Yes" Then
Worksheets("Insert data Purchasing Plan").Rows(row_counter).Copy
Sheets("Purchasing Plan").Select
Rows("15:15").Select
Selection.Insert Shift:=xlDown
End If

'Find the last serial number and assign serial number to the new line

Dim rng As Range
Dim dblMax As Double
Set rng = Range("A1", Range("A65536").End(xlUp))
dblMax = Application.WorksheetFunction.Max(rng)
Dim number As Double
number = dblMax + 1
Sheets("Purchasing Plan").Select
Range("A15") = number

'copy same rows to Log and delete rows in "insert data

If Worksheets("Insert data Purchasing Plan").Cells(row_counter, Add_column) = "Yes" Then
Worksheets("Insert data Purchasing Plan").Rows(row_counter).Cut
Sheets("Log - Copied Lines").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
End If

row_counter = row_counter + 1

Loop


'Put No to Savings In and Delete columns

Dim SaveCol1 As Range
Dim lRow As Long
Set SaveCol1 = Rows(11).Find(What:="Savings In", LookIn:=xlValues, LookAt:=xlWhole)
If SaveCol1 Is Nothing Then MsgBox "Savings Header not Found": Exit Sub
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(15, SaveCol1.Column), Cells(lRow, SaveCol1.Column)).Value = "No"

Dim SaveCol2 As Range
Set SaveCol2 = Rows(11).Find(What:="Delete", LookIn:=xlValues, LookAt:=xlWhole)
If SaveCol2 Is Nothing Then MsgBox "Delete Header not Found": Exit Sub
Range(Cells(15, SaveCol2.Column), Cells(lRow, SaveCol2.Column)).Value = "No"

End Sub
[/TD]
[/TR]
</TBODY>[/TABLE]

 

[Comfy]

I've had a quick look through and moved some stuff around, it could probably be cleaned up some more but I don't want to make too many drastic changes as I don't have sample data to work with.

Option Explicit


Public Sub copy_new_data()


Dim i As Long
Dim column_criteria As Integer
Dim Add_column As Integer
Dim HeaderRow As Range
Dim rng As Range
Dim dblMax As Double
Dim number As Double


'Add lines to PP
Sheets("Insert data Purchasing Plan").Select
'Finding the column number, in which copy criteria is found
Set HeaderRow = Rows(1).Find(what:="Project to be added Y/N", LookIn:=xlValues, lookat:=xlWhole)


If HeaderRow Is Nothing Then Exit Sub
Add_column = HeaderRow.Column






Rows("7:200").Select
ActiveWorkbook.Worksheets("Insert data Purchasing Plan").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Insert data Purchasing Plan").Sort.SortFields.Add _
Key:=Range("A7"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Insert data Purchasing Plan").Sort
    .SetRange Range("A7:ED41")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
.Apply
End With


last_row_insert = Cells(7, 1).End(xlDown).Row


' the last row to check, if it has be be copied : "last_row_insert"
Dim row_counter As Integer
row_counter = 7


'Find the last serial number and assign serial number to the new line
    Set rng = Sheets("Purchasing Plan").Range("A1", Range("A65536").End(xlUp))
    dblMax = Application.WorksheetFunction.Max(rng)
    
    number = dblMax + 1


'copy rows to PP
Do Until row_counter = last_row_insert + 1


    If Worksheets("Insert data Purchasing Plan").Cells(row_counter, Add_column) = "Yes" Then
        Worksheets("Insert data Purchasing Plan").Rows(row_counter).Copy
        Sheets("Purchasing Plan").Select
        Rows("15:15").Insert Shift:=xlDown
        Range("A15") = number
        number = number + 1
        'copy same rows to Log and delete rows in "insert data
        Worksheets("Insert data Purchasing Plan").Rows(row_counter).Cut
        Sheets("Log - Copied Lines").Select
        Rows("1:1").Select
        Selection.Insert Shift:=xlDown
    End If


    row_counter = row_counter + 1


Loop




'Put No to Savings In and Delete columns


Dim SaveCol1 As Range
Dim lRow As Long
Set SaveCol1 = Rows(11).Find(what:="Savings In", LookIn:=xlValues, lookat:=xlWhole)
If SaveCol1 Is Nothing Then MsgBox "Savings Header not Found": Exit Sub
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(15, SaveCol1.Column), Cells(lRow, SaveCol1.Column)).Value = "No"


Set SaveCol1 = Rows(11).Find(what:="Delete", LookIn:=xlValues, lookat:=xlWhole)
If SaveCol1 Is Nothing Then MsgBox "Delete Header not Found": Exit Sub
Range(Cells(15, SaveCol1.Column), Cells(lRow, SaveCol1.Column)).Value = "No"


End Sub

 

[Ambre]

Thank you!
Run time error 1004
Set rng = Sheets("Purchasing Plan").Range("A15", Range("A65536").End(xlUp))

we have Dim rng As Range
I do not see why there is a bug

 

[Comfy]

That's my fault. the Sheet needs to be active.

Sheets("Purchasing Plan").Select
Set rng = Range("A15", Range("A65536").End(xlUp))

 

[Ambre]

Here are the Serial numbers I obtain:

Serial number
1371 error
1338 error
1337 error
1325
1324 ...
1323 new line
1322 new line
1321 new lines starting
1320 line in the file before

I had to had Range("A15") = number, nothing was happening

so code is:
Sheets("Purchasing Plan").Select
Set rng = Range("A1", Range("A65536").End(xlUp))
dblMax = Application.WorksheetFunction.Max(rng)
number = dblMax + 1
Range("A15") = number

 

[Comfy]

I changed your code as you were ascertaining the max number every time the row_counter incremented, this is not required.

I guessed from looking at your code that you only wanted to add a new row when "Yes" appeared in the row so I moved everything into one If statement rather than having multiple.

If Worksheets("Insert data Purchasing Plan").Cells(row_counter, Add_column) = "Yes" Then
        Worksheets("Insert data Purchasing Plan").Rows(row_counter).Copy
        Sheets("Purchasing Plan").Select
        Rows("15:15").Insert Shift:=xlDown
        Range("A15") = number
        number = number + 1
        'copy same rows to Log and delete rows in "insert data
        Worksheets("Insert data Purchasing Plan").Rows(row_counter).Cut
        Sheets("Log - Copied Lines").Select
        Rows("1:1").Select
        Selection.Insert Shift:=xlDown
    End If