Email:      Pass:    Pass?
Advertisements


Free Excel Forum

Macro Insert Lines

Forum Register
Search Excel Forum Posts, Tutorials, Macros, Tips, and More

This is my macro to insert lines if the value in b chanbes. I want it to
inset 26 lines it only inserts 1 please help

Sub Deilv()
Dim LastRow As Long
Dim row_index As Long
Application.ScreenUpdating = False
LastRow = ActiveSheet.Cells(Rows.Count, "b").End(xlUp).Row
For row_index = LastRow - 1 To 26 Step -1
If Cells(row_index, "B").Value <> _
Cells(row_index + 1, "B").Value Then
Cells(row_index + 1, "B").EntireRow.insert _
(x24ShiftDown)
End If
Next
End Sub





Similar Excel Video Tutorials

Helpful Excel Macros

Complete Guide to Printing in Excel Macros - PrintOut Method in Excel
- This free Excel macro illustrates all of the possible parameters and arguments that you can include in the PrintOut Meth
Format Cells in The Long Date Number Format in Excel
- This free Excel macro formats a selection of cells in the Long Date number format in Excel. The Long Date number format
Count The Number of Words in a Cell or Range of Cells in Excel - UDF
- Count words in cells with this user defined function (UDF). This UDF allows you to count the number of words that are w
Hide Specific Comments in Excel - Comments Will Still Display on Hover
- Hide specific comments in Excel with this macro. Comments are still visible on hovering over the cell that contains the
Count The Number of Words in a Cell or Range of Cells in Excel - With User-Specified Delimiter / Separator - UDF
- UDF to count the number of words in a cell or range with a user-specified delimiter. This means that you can tell the f

Similar Topics







I have this macro that inserts a line if the value in D changes and copy the
value in D to A. I want this macro to only start looking in D14 or from row
14.

tx for all the help


Dim row_index As Long
Application.ScreenUpdating = False
lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).row
For row_index = lastrow - 1 To 2 Step -1
If Cells(row_index, "D").Value <> _
Cells(row_index + 1, "D").Value Then
Cells(row_index + 1, "D").EntireRow.Insert _
(xlShiftDown)
Cells(row_index + 1, 1).Value = Cells(row_index + 2, 4).Value
End If
Next
End Sub



have this macro that inserts a line if the value in D changes and copy the
value in D to A. I want this macro to only start looking in D14 or from row
14.

tx for all the help


Dim row_index As Long
Application.ScreenUpdating = False
lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).row
For row_index = lastrow - 1 To 2 Step -1
If Cells(row_index, "D").Value <> _
Cells(row_index + 1, "D").Value Then
Cells(row_index + 1, "D").EntireRow.Insert _
(xlShiftDown)
Cells(row_index + 1, 1).Value = Cells(row_index + 2, 4).Value
End If
Next
End Sub

The macro works. It inserts a entire line every time the value in D changes
and then copies the new value to A in the inserted line. But with at the
moment my hedding in row 13 is also moved down, so I want it to start only in
row 14. I a trying to make a printable price list from a DB.
Thanks.



I have this macro that inserts 26 rows when the value in B changes. (Works
wonderfull)
Now I want the macro to after 26 rows were inserted copy Range B2:K25 to the
2nd row in the range that were inserted.
in other words find a value in B move 2 cells down and past B:K
Hope I make sence. I am inserting a header for invoice lines.



Sub Deilv()
Dim LastRow As Long
Dim row_index As Long
Application.ScreenUpdating = False
LastRow = ActiveSheet.Cells(Rows.Count, "b").End(xlUp).Row
For row_index = LastRow - 1 To 26 Step -1
If Cells(row_index, "B").Value <> _
Cells(row_index + 1, "B").Value Then
Cells(row_index + 1, "B").Resize(26).EntireRow. _
insert Shift:=xlDown
End If
Next
Application.ScreenUpdating = True
End Sub





I have a macro that inserts lines and copy a header when ever the value in B
Changes.
I want to make it a bit easier the 26 lines must be inserted and range
B2:K25 coppied at every page break.

Thanks

Public Sub Deilv2()
Dim LastRow As Long
Dim row_index As Long
Dim rng As Range
Set rng = Range("B2:K25")
Application.ScreenUpdating = False
LastRow = ActiveSheet.Cells(Rows.Count, "b").End(xlUp).Row
For row_index = LastRow - 1 To 26 Step -1
If Cells(row_index, "B").Value <> _
Cells(row_index + 1, "B").Value Then
Cells(row_index + 1, "B").Resize(26).EntireRow. _
insert Shift:=xlDown
rng.Copy Destination:=Cells(row_index + 1, "B").Offset(2)
End If
Next
Application.ScreenUpdating = True
End Sub



I have this macro that inserts lines and copies a invoice header.

Now I want to total the invoice.

In the first row after a value in B in E the word totals must be inserted,
H, I and K must be summed the amount of lines differ on each invoice but
there is a heading from where it must be summed. CTNS(H), QTY(I), Total(K)

Thanks a lot.



Public Sub Deilv2()
Dim LastRow As Long
Dim row_index As Long
Dim rng As Range
Set rng = Range("B2:K25")
Application.ScreenUpdating = False
LastRow = ActiveSheet.Cells(Rows.Count, "b").End(xlUp).Row
For row_index = LastRow - 1 To 26 Step -1
If Cells(row_index, "B").Value <> _
Cells(row_index + 1, "B").Value Then
Cells(row_index + 1, "B").Resize(26).EntireRow. _
insert Shift:=xlDown
rng.Copy Destination:=Cells(row_index + 1, "B").Offset(2)
End If
Next
Application.ScreenUpdating = True
End Sub




I found this macro in this newsgroup, but it is putting the page breaks after
not before the "Results" which in my case is going to be 1/12/2005.

Option Explicit
Sub insert_pagebreak()
Dim lastrow As Long
Dim row_index As Long

lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).row
For row_index = lastrow - 1 To 1 Step -1
If Cells(row_index, "A").Value ="Result" then
ActiveSheet.HPageBreaks.Add Befo = _
Cells(row_index + 1, "A")
End If
Next
End Sub

Sub remove_them()
ActiveSheet.ResetAllPageBreaks
End Sub

Thank you for all your help in advance.



Hi, Im new to Excel, hope you can help me out, I've got this macro:

Code:

Sub delete_rows()
Dim lastrow As Long
Dim row_index As Long
Application.ScreenUpdating = False
lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For row_index = lastrow - 1 To 1 Step -1
If Cells(row_index, "A").Value= "EXTRA" then
Rows(row_index).delete
End If
Next
Application.ScreenUpdating = True
End Sub


But it works only for rows with "EXTRA" word in them.

I need it work also with e.g. "EXTRA_A" "EXTRA_B" "TT_EXTRA" etc. so I guess best would be use wildcard for EXTRA -> "*EXTRA*" but it doesnt work.

Any solutions to this?
Thanks a lot.


I want his macro to after it have inserted the colmns and added the formula to
1. copy range A1 to E1 to every row where the word "Header" is in colmn F.
2. Then copy paste the whole sheet as values.
3. Then the range now standing left of "header" must be copied to the empy
cells beneath each heading.

For example

a b c d e
f
1)12/12/2005 F001 SAO3 1 CCE Header
2)
Detail
3)13/05/2005 A001 SAO4 2 CCI Header
4)
Detail
5)
Detail

Range A1:E1 must be coppied to A2:E2 but range A3:E3 must be coppied to A4:E5
and so on.

I am trying to write a database export in a readble sortable way.

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 09/12/2005 by Nadia
'

'
Columns("A:E").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
ActiveCell.FormulaR1C1 = "=RC[6]"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=RC[8]"
Range("C1").Select
ActiveCell.FormulaR1C1 = "=RC[8]"
Range("D1").Select
ActiveCell.FormulaR1C1 = "=RC[8]"
Range("E1").Select
ActiveCell.FormulaR1C1 = "=RC[8]"
Range("A2").Select
Dim LastRow As Long
Dim row_index As Long
Application.ScreenUpdating = False
LastRow = ActiveSheet.Cells(Rows.Count, "F").End(xlUp).Row
For row_index = LastRow - 1 To 2 Step -1
If Cells(row_index, "F").Value = "Header" Then
Rows(1).Copy Destination:=Rows(row_index + 1)
End If
Next


Thanks




Hello all ,
I found this code from Ron De Bruin to insert page breaks depending on the number of rows.
Works great , but i need to adjust it for my purposes.
I'm helping someone else on this forum for this problem.
In a sheet i define the rows(1:15) to be repeated at the top for printing.
I'd like to insert page breaks from row 16 every RW rows ( RW = define rows in the code)
Has someone have a solution for this.
Many thanks


Code:

Sub Insert_PageBreaks()
    Dim Lastrow As Long
    Dim Row_Index As Long
    Dim RW As Long

    'How many rows do you want between each page break
    RW = 20
    
    With ActiveSheet
        'Remove all PageBreaks
        .ResetAllPageBreaks
        
        'Search for the last row with data in Column A
        Lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
        
        For Row_Index = RW + 1 To Lastrow Step RW
            .HPageBreaks.Add Befo =.Cells(Row_Index, 1)
        Next
    End With
End Sub





Hello all,

I have a spreadsheet that needs formatting. Each row contains bio info and two sets of addresses. I want these to be broken out into three rows so that bio is on the first row followed by a row for each address. I got this to work fine by running the following macro. I ran it twice(once for each address):

Code:

Option Explicit
Sub Make2_rows()
Dim lastrow As Long
Dim row_index As Long
Dim ColtoSplit As Integer
ColtoSplit = 11
' ColtoSplit is the column number to start new 4="D"
Application.ScreenUpdating = False
lastrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For row_index = lastrow To 1 Step -1
Range(Cells(row_index, ColtoSplit), Cells(row_index, 256)).Cut
Range(Cells(row_index + 1, 1), Cells(row_index + 1, 1)).Select
Selection.Insert xlShiftDown
Next
Application.ScreenUpdating = True
End Sub


Then i tried to ran a variety of delete macros, none of which deleted any of the blank rows that were inserted by the macro above. I think this is because the above macro is not really inserting blank rows but parts of rows(my best dummy guess). I dont know much about macros(since i had to take examples i found and run those) so i dont know how locate the problem exactly. Here is one of the macros that is supposed to delete rows but doesnt.

Code:

Public Sub DeleteBlankRows()

Dim R As Long
Dim C As Range
Dim Rng As Range

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Selection.Rows.Count > 1 Then
    Set Rng = Selection
Else
    Set Rng = ActiveSheet.UsedRange.Rows
End If
For R = Rng.Rows.Count To 1 Step -1
    If Application.WorksheetFunction.CountA(Rng.Rows(R).EntireRow) = 0 Then
        Rng.Rows(R).EntireRow.Delete
    End If
Next R

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub


Now this macro delete rows just fine, but it wont delete any of the rows created by the first macro. Can anyone help me out here? Thanks

Andy


I currenlt have a macro that creates a new workbook. At the conclusion of the macro the New WB is active - And currently UNSAVED - Currently named "Book1". I need to get into this file (VBA Project) the Thisworkbook.Before_Print code event which will include the lines

Res = Msgbox("Do you want to print the report starting a new page as the Group number changes?", vbYesNoCancel)
If res = "" then 'User clicked Cancel
Exit Sub
End if
If Res = vbYes then 'User Clicked Yes
Call insert_pagebreak
End if

I've studied Chip Pearson's site, but am still unsure of the correct steps to perform... Can someone assist me?

Code:

Sub insert_pagebreak()
Dim lastrow As Long
Dim row_index As Long

lastrow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row
For row_index = lastrow - 1 To 4 Step -1    '4 is the top data row
      If Cells(row_index, "B").Value  _
           Cells(row_index + 1, "B").Value Then
           ActiveSheet.HPageBreaks.Add Befo = _
           Cells(row_index + 1, "A")
      End If
Next
End Sub





Hi,


Basically I have a nested FOR loop where I gather all the required parameters for my VLOOKUP function, tweak the result, and paste it in the given cell. The goal of this function is to take the rate for a given commodity (designated by ID#), use vlookup to find the inflation rate for that commodity, then do some math to find out what the rate will be post-inflation. Finally I paste that result into the active worksheet.

Code:

        NumRows = Cells(Rows.Count, 1).End(xlUp).Row
        NumCols = Cells(Columns.Count, 1).End(xlToLeft).Column
        
   '***Loops through row by row***'
        For row_index = 4 To NumRows
            
       '***Loops through every column in row***'
            For col_index = FirstFcstCol To NumCols
           '***Sets VLOOKUP target to the ID#***'
                Target = Cells(row_index, 1)
           '***Sets VLOOKUP Col_index***'
                Offset = 3 + Cells(1, col_index).value
           '***Sets VLOOKUP Range***'
                LastCol = Sheets("XYZ").Cells(1, Columns.Count).End(xlToLeft).Column
                LastRow = Sheets("XYZ").Cells(Rows.Count, 1).End(xlUp).Row
                lookup_range = Sheets("XYZ").Range(Cells(4, 1), Cells(LastRow, LastCol))
           '***Uses VLOOKUP to find the forecast %***'
                inflation_pct = Application.WorksheetFunction.VLookup(Target, lookup_range, Offset, False)
           '***Calculates the inflated index***'
                Last_qtr_baseline = Cells(row_index, LastHistCol).value
                Inflated_index = Last_qtr_baseline * (1 + inflation_pct)
                ActiveSheet.Cells(row_index, col_index).value = Inflated_index
            Next col_index
            
        Next row_index


All of the cells in my range are remaining empty so I'm doing something wrong. I'm not sure if its in the construction of my loop, how I am using VLOOKUP, or how I am trying to insert values into the spreadsheet.

Help is much appreciated. Thanks!


Hi all,

I have a spreadsheet that lists prices for a given item at each quarter during the fiscal year. I wrote a macro that indexes these prices. So the first known price (first quarter, 2000), gets transcribed to a value of 100. Then, all of the following data is based off of that 100. For example if something cost $1 in first quarter, 2000, but then it costs $2.50 at some later point, the value for that later point would be 250 (1/2.5*100)

Here's the macro:
Code:

Sub makeBase100()

Application.ScreenUpdating = False

NumRows = Sheets("PADS Indices").Cells(Rows.Count, 1).End(xlUp).Row
NumCols = Sheets("PADS Indices").Cells(1, Columns.Count).End(xlToLeft).Column

    For row_index = 3 To NumRows Step 1
        baseline = Sheets("PADS Indices").Cells(row_index, 3).Value
        For col_index = NumCols To 3 Step -1
            On Error Resume Next
            this = Sheets("PADS Indices").Cells(row_index, col_index).Value
            b100val = this / baseline * 100
            If Err = 0 Then
                b100val = this / baseline * 100
            Else
                b100val = "#N/A"
            End If
            On Error GoTo 0
            Sheets("PADS Indices").Cells(row_index, col_index).Value = b100val
        Next col_index
    Next row_index
        
Application.ScreenUpdating = True

End Sub


I've ran this three times now. Twice it has taken 20+ minutes to complete, but once it took < 5 seconds. Now I am cycling through roughly 10,000 cells, and although that could explain why it's taking forever, it doesn't explain why one time it took 5 seconds. I also used 3 different sets of data for all of these trials, but they were very similar and all involved calculating ~1000 cells. So what's going on here


I have a macro called import which imports data from one spreadsheet to another. The imported data is many rows containing a list of numbers. I'd like to baseline each row so that the first number of each row is 100, and then adjust the other numbers of the row accordingly.

Here is my macro to make the base 100:
Code:

Sub makeBase100()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

NumRows = Sheets("X").Cells(Rows.Count, 1).End(xlUp).Row
NumCols = Sheets("X").Cells(1, Columns.Count).End(xlToLeft).Column

    For row_index = 3 To NumRows Step 1
        
        'Finds first populated column of this row and stores it as the baseline val
        baselineCol = Cells(row_index, 2).End(xlToRight).Column
        If Len(Cells(row_index, 3)) > 0 Then baselineCol = 3
        baseline = Cells(row_index, baselineCol).Value
        
        For col_index = NumCols To 3 Step -1
            On Error Resume Next
            'If this point came before the baseline, then we'll just set it to 100 as well
            If col_index < baselineCol Then
                this = baseline
            Else
                this = Sheets("X").Cells(row_index, col_index).Value
            End If
            b100val = this / baseline * 100
            If Err = 0 Then
                b100val = this / baseline * 100
            Else
                b100val = 100
            End If
            On Error GoTo 0
            Sheets("X").Cells(row_index, col_index).Value = b100val
        Next col_index
    Next row_index

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub


Now, if I run the import macro, Then run the makeBase100 macro, everything works 100% as expected. However I'd like to do both steps at the same time.
If I do either of:
A) call makeBase100 at the end of import macro
B) create a new macro which calls import, then makeBase100.
Then the code won't work as expected, and basically my entire imported table gets filled with values of '100'.
Part of the problem seems to be that this line:
Code:

baselineCol = Cells(row_index, 2).End(xlToRight).Column


Is supposed to return the first populated cell of the given row, starting at column B. However, this, which normally returns the value '3', decides to return the value '256' when I call makeBase100 with import. It seems as if makeBase100 is running before import completes importing the data. This would cause it to not recognize any populated cells.

I make sure to call makeBase100 after import, so I'm not sure why this is happening. makeBase100 always works fine when called after any non-import functions. Any ideas?


I have a rake of files where the file name is in a spreadsheet column but the
file extension is not. There are only two possibilities .pdf or .tif.

How do I get the bit marked ** to work??

I can get the filename from the worksheet by a loop

Filename = Worksheets(SheetName).Cells(row_index, column_index).Value

What I want to do then is

vFile = filename & ".PDF"
vPath = "http:\\amsds0004\chelmsford\ECR_metrics\"

'If the file exists with a PDF extension then ...
** If exists vPath + vFile then
With Worksheets(SheetName)
.Hyperlinks.Add .Cells(row_index, column_index), vFile
End With
'Otherwise it must be a TIF extension so ...
Else
vFile = filename & ".TIF"
With Worksheets(SheetName)
.Hyperlinks.Add .Cells(row_index, column_index), vFile
End With
End if


Thanks Paul




Hey,

I just need to insert formula in a cell through vb code.

I use Leith Ross code for this macro. But I have more than 5000 rows.

Every time this macro insert formula from the first to till last row,
that consume more than 20 minutes.

Is it possible to find only the last Row and insert formula.?
Code:

  Dim Cell As Range
  Dim LastRow As Long
  Dim R As Long
  Dim Wks As Worksheet
  Dim lRow As Long
  
    Set Wks = ActiveSheet
    LastRow = Wks.UsedRange.Rows.Count - Wks.UsedRange.Row + 1
      
      For R = Wks.Range("j2:m40").Row To LastRow
       If Wks.Cells(R, "A") <> "" Then
        
        Wks.Cells(R, "J").Formula = "=IF($H" & R & "<>"""",($H" & R & "*$I" & R & "),"""")"
        Wks.Cells(R, "K").Formula = "=IF($J" & R & "<>"""",($H" & R & "-$J" & R & "),"""")"
        Wks.Cells(R, "m").Formula = "=IF($k" & R & "<>"""",($k" & R & "+$j" & R & "-$l" & R & "),"""")"
          
        End If
      Next R
      
End Sub


Your help is much appreciated.
Charles


I have the below code in a macro that by itself runs great. I want to stop it
at row 8. The data starts in row 9 and ends when it ends - the amount of rows
always varies. I have tried using different "Do", "Do Until" but have not
been successful. Any help would be greatly appreciated.

Darryl


Range("a8").Select

Dim lastrow As Long, formRow As Long
Dim i As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
formRow = lastrow + 1
For i = lastrow To 2 Step -1
If Cells(i, 31) <> Cells(i - 1, 31) Then
Cells(formRow, "K").Formula = "=SubTotal(9," & _
"K" & i & ":K" & formRow - 1 & ")"
Rows(i).insert shift:=xlShiftDown
formRow = i

End If

Next




Hello,

This is probably a common problem but I can find the solution. In my list below I need to insert a blank row when the value in col B changes from 1 to 2 and from 2 to 3 etc.

ColA ColB
DUT 1
ROP 1
ROS 1
ROS 1
Lap 2
PFB 2
PFB 2
ABC 3
CDL 3
LAP 3
Dut 4
DUT 4

I have the following code but it doesn't work.It keeps inserting randon lines.

Sub InsertRow()
Dim LastRow As Long
Dim i As Integer
Dim TopCell As Range

Range("B1").Select
Set TopCell = Range("B1").End(xlDown)

LastRow = Cells(Cells.Rows.Count, TopCell).End(xlUp).Row
For i = LastRow To 2 Step -1
If Cells(i, TopCell).Value <> Cells(i - 1, 0).Value Then
Rows(i).Insert
Rows(i).Interior.ColorIndex = xlNone
End If
Next i

End Sub


Thanks




I'm after code to add two rows of cells but only 6 columns wide every time a value changes in a columns. e.g.
before;
1
1
1
2
2
3
3
3
3

after;
1
1
1
(insert two rows, 6 columns wide here)
2
2
(insert two rows, 6 columns wide here)
3
3
3
3
(insert two rows, 6 columns wide here)

This is the code i have so far;

Sub InsertBlankRows()

Dim LastRow As Long
Dim i As Long

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

For i = LastRow To 2 Step -1
If i = 2 Then
'Do nothing
ElseIf Cells(i, "A") <> Cells(i - 1, "A") Then
Cells(i, "A").Insert
End If
Next i

End Sub

This code inserts one cell below each of the values when they change but one column only

help would be greatly appreciated.

I have written a long bit of code, which works fine. I decided to add an error handler just in case of any errors. I have run through my code numerous times to confirm that there is no error, but the msgbox still pops up. Any ideas/suggestions?

Code:

Sub Amazing_Project()
    Dim FirstRow As Integer
    Dim LastRow As Long
    Dim LastCol As Long
    Dim rng As Range
    
    FirstRow = 1
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    LastCol = Cells(1, 1).End(xlToRight).Column
    
   On Error GoTo Errhandler:
    Application.ScreenUpdating = False
    For i = LastRow To 3 Step -1
        If Cells(i, 2) <> Cells(i, 2).Offset(-1, 0) Then
            Rows(i).Insert
        End If
    Next i
    
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    n = 2
    Cells(1, 1).Resize(, LastCol).Font.Bold = True
    Do Until n = LastRow
        If LastRow = 1 Then Exit Do
            If Cells(n, 1) = "" Then
                Range(Cells(1, 1), Cells(1, LastCol)).Copy Cells(n, 1)
            End If
    n = n + 1
    Loop
    
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Dim StrtRow As Long
    StrtRow = LastRow
    
    For i = LastRow To 1 Step -1
        If Cells(i, 1) = Cells(1, 1) Then
            StrtRow = i
        Range(Cells(StrtRow, 1), Cells(LastRow, LastCol)).Subtotal GroupBy:=3, Function:=xlCount, TotalList:=Array(4), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        LastRow = StrtRow - 1
        End If
    
    Next i
    
        LastRow = Cells(Rows.Count, 3).End(xlUp).Row
    
    For i = LastRow To 2 Step -1
        If Cells(i, 3) = "Grand Count" Then
            Cells(i, 3) = CStr("Section " & Cells(i, 3).Offset(-2, -1).Value & " Available Seats")
            With Cells(i, 3).Resize(, 2).Font
                .Bold = True
            End With
        End If
    Next i
    
    For i = LastRow - 1 To 2 Step -1
        If Cells(i, 1) = "" Then
            Cells(i, 1).Resize(, 2).FillDown
            Rows(i).Font.Bold = True
            Cells(i, 1).Resize(, LastCol).Interior.ColorIndex = 35
        End If
    Next i
    
    Cells.Font.Name = "Times New Roman"
    Columns(1).Resize(, LastCol).AutoFit
    ActiveSheet.Outline.ShowLevels rowlevels:=2
    
    LastRow = Cells(Rows.Count, 3).End(xlUp).Row
    Range(Cells(1, 1), Cells(LastRow, LastCol)).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = xlNone
    
    Application.ScreenUpdating = True
    
Errhandler: MsgBox "There has been an unexpected error.  Please contact the administrator."
End Sub





Hi, I had the following script and I am having problems to uploading the Data from an another spreadsheet. I am getting the error "Run TIme Error 9 - Subscript out of range". I am getting the error in the line (see *****ERROR****** below). Any help will be really appreciate it.

Sub UpdateDataList()

' UpdateManagerList Macro
' Macro recorded 8/27/2007 by CarlosPeres
'

Dim LastRow As Long
Dim Vendor As String
Dim DstWkb As Workbook
Dim DstWkc As Workbook
Dim SrcWkb As Workbook
Dim DstWks As Worksheet
Dim SrcWks As Worksheet

Range("B9:BF99").ClearContents

If WorkbookIsOpen("ALL_Data.xls") <> True Then
Workbooks.Open Filename:="C:\temp\ALL_Data.xls"
End If

Set SrcWkb = ThisWorkbook
Set SrcWks = SrcWkb.Worksheets("All") *****ERROR******
With SrcWks
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
If LastRow < 9 Then LastRow = 9
End With

On Error Resume Next
Set DstWkb = Workbooks("ALL_Data.xls")
If Err.Number = 9 Then
MsgBox "The Workbook " & Chr$(34) & "ALL_Data.xls" & Chr$(34) & vbCrLf _
& "must be open to run this macro."
Exit Sub
Else
On Error GoTo 0
End If


For Each DstWks In DstWkb.Worksheets
If DstWks.Cells(3, "C") <> "" Then
SrcWks.Cells(LastRow, "B") = DstWks.Cells(3, "C")
SrcWks.Cells(LastRow, "C") = DstWks.Cells(4, "C")
SrcWks.Cells(LastRow, "D") = DstWks.Cells(5, "C")
SrcWks.Cells(LastRow, "E") = DstWks.Cells(8, "C")
SrcWks.Cells(LastRow, "N") = DstWks.Cells(9, "C")
SrcWks.Cells(LastRow, "K") = DstWks.Cells(42, "C")
SrcWks.Cells(LastRow, "O") = DstWks.Cells(10, "C")
SrcWks.Cells(LastRow, "P") = DstWks.Cells(11, "C")
SrcWks.Cells(LastRow, "Q") = DstWks.Cells(14, "C")
SrcWks.Cells(LastRow, "T") = DstWks.Cells(15, "C")
SrcWks.Cells(LastRow, "W") = DstWks.Cells(16, "C")
SrcWks.Cells(LastRow, "Z") = DstWks.Cells(19, "C")
SrcWks.Cells(LastRow, "AA") = DstWks.Cells(20, "C")
SrcWks.Cells(LastRow, "AB") = DstWks.Cells(22, "C")
SrcWks.Cells(LastRow, "AC") = DstWks.Cells(23, "C")
SrcWks.Cells(LastRow, "AD") = DstWks.Cells(24, "C")
SrcWks.Cells(LastRow, "AE") = DstWks.Cells(25, "C")
SrcWks.Cells(LastRow, "AF") = DstWks.Cells(26, "C")
SrcWks.Cells(LastRow, "AI") = DstWks.Cells(27, "C")
SrcWks.Cells(LastRow, "AJ") = DstWks.Cells(28, "C")
SrcWks.Cells(LastRow, "AK") = DstWks.Cells(31, "C")
SrcWks.Cells(LastRow, "AL") = DstWks.Cells(32, "C")
SrcWks.Cells(LastRow, "AM") = DstWks.Cells(33, "C")
SrcWks.Cells(LastRow, "AN") = DstWks.Cells(34, "C")
SrcWks.Cells(LastRow, "AQ") = DstWks.Cells(35, "C")
SrcWks.Cells(LastRow, "AT") = DstWks.Cells(36, "C")
SrcWks.Cells(LastRow, "AU") = DstWks.Cells(39, "C")
SrcWks.Cells(LastRow, "AV") = DstWks.Cells(40, "C")
SrcWks.Cells(LastRow, "AY") = DstWks.Cells(41, "C")
SrcWks.Cells(LastRow, "BB") = DstWks.Cells(43, "C")
LastRow = LastRow + 1
End If
Next DstWks

Windows("ALL_Data.xls").Activate
ActiveWindow.Close

End Sub


Public Function WorkbookIsOpen(wbname) As Boolean

' Returns TRUE if the workbook is open

Dim x As Workbook
On Error Resume Next
Set x = Workbooks(wbname)
If Err = 0 Then
WorkbookIsOpen = True
Else
WorkbookIsOpen = False
End If


End Function


I made the code below by merging a few independent codes, when I run it it gives me an error for duplicate declaration of i; dim i As Long part.

Can anyone suggest a way around this?? since I would need the macro to do everything by the click of a button. or, alternately is there any way to "call" the next macro once the previous one is complete??


Quote:

Sub formatSheet()
Application.ScreenUpdating = False
Dim rCount As Long, i As Long
rCount = ActiveSheet.UsedRange.Rows.Count
For i = rCount To 1 Step -1
If Application.WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, 2))) < 1 Then
Cells(i, 1).EntireRow.Delete
End If
Next
Application.ScreenUpdating = True


Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("C:D").Select
Selection.Delete Shift:=xlToLeft
Columns("D:E").Select
Selection.Delete Shift:=xlToLeft
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Columns("I:I").Select
Selection.Delete Shift:=xlToLeft
Columns("K:L").Select
Selection.Delete Shift:=xlToLeft
Columns("L:M").Select
Selection.Delete Shift:=xlToLeft
Columns("M:M").Select
Selection.Delete Shift:=xlToLeft
Columns("N:N").Select
Selection.Delete Shift:=xlToLeft
Columns("O:O").Select
Selection.Delete Shift:=xlToLeft
Columns("P:P").Select
Selection.Delete Shift:=xlToLeft
Columns("R:R").Select
Selection.Delete Shift:=xlToLeft
Columns("S:S").Select
Selection.Delete Shift:=xlToLeft
Columns("T:T").Select
Selection.Delete Shift:=xlToLeft
Columns("U:U").Select
Selection.Delete Shift:=xlToLeft
Columns("V:W").Select
Selection.Delete Shift:=xlToLeft
Columns("W:W").Select
Selection.Delete Shift:=xlToLeft

Dim LastRow As Long
Dim i As Long
LastRow = Cells(Rows.Count, "B").End(xlUp).Row

Application.ScreenUpdating = False

For i = LastRow To 1 Step -1
With Cells(i, "B")
If UCase(.Value) = "MEDLINE INDUSTRIES, INC." Then
.Resize(5, 1).EntireRow.Delete
End If
End With
Next i

Application.ScreenUpdating = True

Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Columns("A:A").Select
Selection.Insert Shift:=xlToRight

End Sub




Hi - I am a new member of this news group and also new to VBA for
Excel.
I have some programming background that is rather dated (fortran 77,
Basic, and a specialty language called DAL (which, as far as I know is
no longer in existence)). I have procured a few books and surfed the
Excel help sites and have made some headway however, I find that I need
some help with a macro that I am developing.

The macro is intended to create borders around a selected range of
cells. I started by recording a macro to accomplish this. With a
little work I got this to work when I selected a cell in Column A. Now
I want to expand it to create the same borders by selecting the cells
in Column A that has a numerical value. It can do this either
individually or by activating all the cells in Column A that meets the
requirement and doing them at one time. The other criteria for the
macro is to ignore those rows that have already received their borders
(this part I have not even tackled yet, primarily due to the fact that
I can't get the first part to work yet). I have included a copy of
the macro for your perusal and hopefully comments.

In the macro below I receive a 'Run time error' 424 stating that an
Object is required for the line Lastrow =. I don't understand what
Object it is looking for.

Here's hoping that help is on the way!!! And Thank You in advance.


Sub MULTIBORDERS()
' MULTIBORDERS Macro
' Creates multiple borders based on a number being
' entered into column A
'
'

Dim Lastrow As Long
Dim Row_Index As Long
Dim RW As Integer

'Max number of rows
RW = 395
With ActiveSheet
'Search for the last row with data in Column A
Lastrow = Activate.Cells(Rows.Count, "1").End(xlUp).Row
For Row_Index = RW + 5 To Lastrow Step RW
Next
End With
'ActiveCell.Range("A1:I1").Select

'Create a set of borders for each line of the form that has
'information
Selection.BORDERS(xlDiagonalDown).LineStyle = xlNone
Selection.BORDERS(xlDiagonalUp).LineStyle = xlNone
With Selection.BORDERS(xlEdgeLeft)
..LineStyle = xlContinuous
..Weight = xlThick
..ColorIndex = xlAutomatic
End With
With Selection.BORDERS(xlEdgeTop)
..LineStyle = xlContinuous
..Weight = xlThin
..ColorIndex = xlAutomatic
End With
With Selection.BORDERS(xlEdgeBottom)
..LineStyle = xlContinuous
..Weight = xlThin
..ColorIndex = xlAutomatic
End With
With Selection.BORDERS(xlEdgeRight)
..LineStyle = xlContinuous
..Weight = xlThick
..ColorIndex = xlAutomatic
End With
With Selection.BORDERS(xlInsideVertical)
..LineStyle = xlContinuous
..Weight = xlThin
..ColorIndex = xlAutomatic
End With
Exit Sub
End Sub




Hi,

I am trying to run a macro that will scan data in column A until there is none left & then count the number of characters in its corresponding B cell. For any B-values that are not equal to 64, the entire row should be deleted. I have tried the following macros, but none of them specify any conditions about the A column, so they take an extremely long time to run:

Code:

Sub Len()

Dim i As Long

    For i = Range("B:B").Rows.Count To 1 Step -1
    If Len(Range("B:B").Rows(i)) <> 64 Then
        Range("B:B").Rows(i).EntireRow.Delete
    End If
    Next i

End Sub


Code:

Sub Len()

Dim i As Double

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    For i = Worksheets(1).Range("B:B").Rows.Count To 1 Step -1
        If Len(Range("B:B").Cells(i)) <> 64 Then
            Range("B:B").Cells(i).EntireRow.Delete
        End If
    Next i
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub


Code:

Sub Len()

Dim LastRow As Long
Dim i As Long
    LastRow = .Cells(Rows.Count, "B").End(xlUp).Row
    For i = LastRow To 1 Step -1
    If Len(.Cells(i, "B").Value) <> 64 Then
        .Rows(i).Delete
    End If
    Next i
    End With
End Sub


Any suggestions on what I can do to speed this up?

Thank you for your time.


I received a macro from VBA Noob and Stanleydgromjr which joins some specific rows. The macro appears to work very well Code:

Option Explicit
Sub JoinData()
    Dim LastRow, i As Long
    Dim Msg As String
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = LastRow To 2 Step -1
        If Cells(i - 1, "A").Value & Cells(i - 1, "B").Value _
        = Cells(i, "A").Value & Cells(i, "B").Value Then
            Msg = Cells(i, "D").Value & " " & Chr(10) & Msg
            Cells(i, "D").EntireRow.Delete
        Else
            With Cells(i, "D")
                Msg = .Value & Chr(10) & Msg
                .Value = Msg
                Msg = ""
            End With
        End If
    Next i
    With Columns(4)
        .ColumnWidth = 50
        .WrapText = True
    End With
    Cells.EntireRow.AutoFit
    On Error Resume Next
    Columns("D:D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Columns("C:C").Delete Shift:=xlToLeft
    Range("D1").Select
End Sub


with only one issue. The results show some cells with no text, but a just a series of '"#" signs. If I expand the specific cell, it shows the text, just as it should. The proper text is also displayed in the 'formula bar'. The 'wrap text' is activated. However, if I want to export the file to a .txt file, the results for that specific cell are just number signs again. In working through the data, it appears that the cells with just number signs may have a common thread of more than four lines of text. Beyond that, I am not sure what to look for.

Any advice is appreciated.