Cleaning up Macros and stringing them together?

JM144 · Jul 11, 2011

I have four macros that I have Written/Copied/Recorded. If I use all four of them in specific ways my task is completed to my specifications. I want to be able to string all four of these together into one seamless macro, however, there are some caveats. The First and third macros only need to be run once, while the second and fourth need to be run a variable number of times. The second macro must be run until it reaches a certain name (the "182" is an index number that is common to the beginning of each evaluation of data, I need to stop at a particular name, not a number) and the fourth runs until it can no longer find any rows with the text "page" in it. Also, the macros are undoubtedly written in an extremely inefficient way. Any help streamlining any or all of these pieces would be greatly appreciated. I have posted the code below.Thanks in advance!

 Sub Reposition()
Range("A1:F10000").Select
Selection.Cut
ActiveWindow.ScrollRow = 3889
ActiveWindow.SmallScroll Down:=507
Application.Goto Reference:="R10001C1"
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=18
Range("A1").Select
End Sub

Sub Cleanup()
ActiveCell.Offset(2, 0).Range("A1").Select
Cells.Find(What:="182", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _
.Activate
ActiveCell.Range("A1:B1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Application.Goto Reference:="R3000C2"
Selection.End(xlUp).Select
ActiveCell.Offset(2, 0).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Select
Selection.Copy
Selection.End(xlDown).Select
ActiveCell.Offset(0, -1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.End(xlUp).Select
ActiveCell.Offset(0, -1).Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Range("A1").Select
Application.CutCopyMode = False
Selection.EntireRow.Delete
Selection.End(xlDown).Select
End Sub

Sub DeleteBlankRows()
Dim i As Long
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Range("A1:C5000").Select
For i = Selection.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
Selection.Rows(i).EntireRow.Delete
End If
Next i
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

Sub DeletePageData()
Range("A1").Select
Cells.Find(What:="page", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate
Selection.EntireRow.Delete
End Sub

Michael M · Jul 15, 2011

If you want to remove the "Page" rows at the end, then I have added a couple of lines to your code.

Code:

Sub Cleanup()

Dim llr As Long, r as long
llr = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:D" & llr).Cut Destination:=Range("B" & llr + 1) 'will paste one row past the last row
Range("A1").Select

Dim NextDataStart As Long, NextDataEnd As Long, nr As Long, c As Long, nrr As Long, nrrr As Long, lr As Long
Dim DataKey As String
lr = Cells.Find(What:="Unmanaged Assets", After:=Range("A1"), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row 'original last row of data, which will control how far the macro goes
nrr = Cells(Rows.Count, "A").End(xlUp).Row + 1 'nextrow
NextDataStart = 1
NextDataStart = Cells.Find(What:=" 182", After:=Range("A" & nrr), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
While NextDataStart < lr

DataKey = ActiveSheet.Cells(NextDataStart, 3).Value
NextDataEnd = ActiveSheet.Range("C" & NextDataStart).End(xlDown).Row

nr = Cells(Rows.Count, "A").End(xlUp).Row + 1 'nextrow
ActiveSheet.Range("C" & NextDataStart & ":D" & NextDataEnd).Cut Destination:=ActiveSheet.Cells(nr, 2)
For c = nr To nr + (NextDataEnd - NextDataStart)
Cells(c, 1) = DataKey
Next c
Rows(nr).EntireRow.Delete
lr = lr - 1
nrr = Cells(Rows.Count, "A").End(xlUp).Row + 1 'nextrow
NextDataStart = Cells.Find(What:=" 182", After:=Range("A" & nrr), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
Wend
for r = llr to 3 step -1
  If range("B" & r).value="Page" then rows(r).delete
next r
End Sub

Where did you want the dialog box to appear and I guess....why ??

JM144 · Jul 15, 2011

Michael,

Thanks so much for the help! I'm wondering if it would be possible to add a button on my worksheet that would activate some sort of dialog box that would enable a bulletproof process of importing raw data? The raw data file is in csv format and is e-mailed to me on a daily basis. I'm not sure if this is possible but figure you're the guy to ask! Thanks again.

Michael M · Jul 15, 2011

The code for importing CSV files is covered here at Chip Pearsons site.
There are a number of different methods and I'm sure one will suit.
Post back with more info if these aren't suitable.

http://www.cpearson.com/excel/ImpText.aspx

JM144 · Jul 15, 2011

Michael,

I used your link and the code supported by the site but I think it is much too complex and it gave me a close but unfortunately useless output. It did lead me to another potential option though. I recorded the process through Excel's built-in converter and got some code. All I need to do is figure out how to select a file to import rather than using the static code provided. Everything should be good to go except for the file name and path.

Code:

Sub InRaw()
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Users\Jonathan\Desktop\Sector.Allocation.07.06.11.csv", Destination _
        :=Range("$A$1"))
        .Name = "Sector.Allocation.07.06.11"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

Any ideas would, once again, be greatly appreciated! Thanks.

Cindy Ellis · Jul 15, 2011

I've never used querytables to open a text file, and I couldn't get the syntax to work properly. This is how I select and open csv files from VBA:

Code:

Sub InRaw()
Dim fileToOpen
'
fileToOpen = Application.GetOpenFilename("Text Files (*.csv), *.csv")
If fileToOpen <> False Then
    Workbooks.OpenText FileName:=fileToOpen, _
        Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, FieldInfo:=Array(1, 1)
End If
    
End Sub

Cleaning up Macros and stringing them together?

JM144

New Member

Michael M

Well-known Member

Excel Facts

JM144

New Member

Michael M

Well-known Member

JM144

New Member

Cindy Ellis

MrExcel MVP

Similar threads

Forum statistics

Share this page

Cleaning up Macros and stringing them together?

JM144

New Member

Michael M

Well-known Member

Excel Facts

JM144

New Member

Michael M

Well-known Member

JM144

New Member

Cindy Ellis

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock