Macro Insert Lines

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!

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

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 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

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

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?

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 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 all,

Instead of having to select a range then run a macro to count visble cells,
It maybe more practicle for my needs to have the macro detect all ranges given or found and return the count value to a specific cell location either above or below the range for count.

I've been working with this code but yet to get it to return the correct values.
Currently, this is a simple count macro for the found ranges. If the count formula
looks odd to you, it because I was tossing around the idea of it just filling in a count formula for the relative range to I could actually see the range that's being counted.
However, I think I'd prefer it to just return counted range value.

If you can take it a step further to include only visible cells, that would be awesome.


Quote:

Sub Count()
Dim Cx As Long
Dim lastrow As Long
With Sheets(1)

lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Cx = Cells(2, Columns.Count).End(xlToLeft).Column
MsgBox "Cx= " & Cx
MsgBox "lastrow= " & lastrow
'With Range("G1:Cx" & WorksheetFunction.Max(3, lastrow))
For I = 7 To Cx ' where column G=7 & Cx = Last cell in row 1 with data


' Set FindIt = Sheets(1).Range("G1" & ":" & Cx & "1").Find(what:=Sheets(1).Range("G1" & ":" & Cx & "1").Value)
' If Not FindIt Is Nothing Then
' Cells(1, I).Formula = "= WorksheetFunction.Count" & "(" & """"" & ""3"" & "","" & i & "":"" & LastRow & "","" & i &""""" & ")"
Cells(1, I).Formula = "=Count(" & """"" & ""3,"" & i & "":"" & LastRow & "","" & i &""""" & ")"

' End If

Next I
' End With
End With
'OutPL.Cells(, "R").Value = Cells(i, "I").Value
' Cells(2,findit.Column).Value = WorkSheetFunction.Count(3,Cx:LastRow,Cx)
End Sub


Attached is my test workbook
Any help again is appreciated.
Thanks,

BDB

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.

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.

Range("A2:D2").Select
Selection.Copy
Sheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlAll,
Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Sheet1").Select
Range("A2" xlDropDown)
If Cells (row_index, "A").Value <>
End Sub

I know I need a bid more experience but learning as I go.
I want to copy lines to a sheet, transposed, and print.
Then the macro must go to the next line and do this again
and stop at the last line.