Free Microsoft Excel 2013 Quick Reference

Combination macro Results

I am new to macros and I have tried several tips that have not worked for me. This is my 1st post so please bear with me.
I am running a macro where I am combining the age in groups of 15 in a pivot table. However, the amount of data changes daily but my macro does not recognize the changes so I cannot get the macro to group. Here is my code. I always got an error so I simply entered "~" for the # of rows and then manually enter the # of rows in the spreadsheet when the runtime error '1004' occurs. I basically use this as a pause in the macro so that I can enter the rows and then run the remainder of the macro and that works as a work a round.

Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Columns("A:A").Select
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Detail!R1C1:R~C11").CreatePivotTable TableDestination:="", TableName:= _
"PivotTable1", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select

I have 60 data files in a folder and a file that is a master file that is a combination of the 60 files. The 60 files all represent different categories, but when I was creating the data files, I forgot to write down which piece of data came from which file. My question is:

Is there a macro that takes the test from a cell in my master file, looks through all the files in a folder, opens each one and does a vlookup. If the vlookup returns the exact name of the file, it stops, but if it doesn't return the exact name, it continues going through the 60 files until a name is returned?

Thanks.

I have two sets of code that are working successfully thanks to Jindon & another thread but I don't know how to put them together. I am getting an error because I'm repeating the "i".
Here is the two codes:
Code:
Sub testcombinetwo()
'pasted & editted from http://www.mrexcel.com/forum/showthread.php?t=99187
FinalRowSh1 = Worksheets("Master").Range("A65536").End(xlUp).Row
FinalRowSh2 = Worksheets("WeeklyJob").Range("A65536").End(xlUp).Row

For i = FinalRowSh2 To 1 Step -1
For J = FinalRowSh1 To 1 Step -1
If Worksheets("Master").Cells(J, 1) = Worksheets("WeeklyJob").Cells(i, 1) And Worksheets("Master").Cells(J, 1) =
Worksheets("WeeklyJob").Cells(i, 1) Then
Worksheets("Master").Cells(J, 3) = Worksheets("WeeklyJob").Cells(i, 3)
Worksheets("Master").Cells(J, 4) = Worksheets("WeeklyJob").Cells(i, 4)
Worksheets("Master").Cells(J, 5) = Worksheets("WeeklyJob").Cells(i, 5)
Worksheets("Master").Cells(J, 6) = Worksheets("WeeklyJob").Cells(i, 6)
End If
Next J
Next i

'following portion from from jindon's reply on mrexcel
Dim a, i As Long, ii As Integer, z As String
a = Sheets("WeeklyJob").Range("a1").CurrentRegion.Resize(, 6).Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        z = a(i, 1) & ";" & a(i, 2)
        If Not .exists(z) Then
            .Add z, Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5), a(i, 6))
        End If
    Next
    a = Sheets("Master").Range("a1").CurrentRegion.Resize(, 6).Value
    For i = 1 To UBound(a, 1)
        z = a(i, 1) & ";" & a(i, 2)
        If .exists(z) Then
            w = .Item(z)
            For ii = 3 To 6: a(i, ii) = w(ii - 1): Next
            .Remove z
        End If
    Next
    If .Count > 0 Then
        Sheets("Master").Range("a" & Rows.Count).End(xlUp)(2) _
        .Resize(.Count, 6).Value = Application.Transpose(Application.Transpose(.items))
    End If
End With
End Sub
Thank you gurus for your wisdom & constant guidance!

I am using Excel 2003.
The code is meant to:
match column A & column B data of Worksheet(WeeklyJob) to column A & column B of Worksheet(Master) then if match is found copy column C through column F into Worksheet(Master) column C through F (and overwrite any [outdated] existing data there may be in those columns [thus updating the job's weekly charges, etc.]).
If match is not found I would like it to copy entire row from Worksheet(WeeklyJobs) into first blank row at end of Worksheet(Master) (thus giving me a new record of a new job from the weekly report).
All the columns in both worksheets are labeled the same (& row 1 is headings).
(thread http://www.mrexcel.com/forum/showthr...11#post1600311)

Sample of my data:
Before Macro:
Worksheet(Master)
A B C D E F
Tom Jr 2 3 4 5
Tom Sr 2 3 4 5
Tom 2 3 4 5
Jen 2 3 4 5
Worksheet(WeeklyJob)
A B C D E F
Tom Sr 7 7 7 7
Xav Sr 8 8 8 8
After macro I would like it to perform/look like this:
Worksheet(Master)
A B C D E F
Tom Jr 2 3 4 5
Tom Sr 7 7 7 7
Tom 2 3 4 5
Jen 2 3 4 5
Xav Sr 8 8 8 8
Worksheet(WeeklyJob)
A B C D E F
Tom Sr 7 7 7 7
Xav Sr 8 8 8 8

I need a macro that will copy/combine data for several workbooks from sheets *.Newvehicles (each work sheet will have a different worksheet ending in for eg newton.newvehicles columnns O:U

I the current workbook "Consolidated New Vehicles" Sheet1, the data must be copied/consolidated into this new workbook, except the data containing the words Total for eg Total Units, Total Value

See sample data below-In this example the data must be copied up to line 20. Row 1 must be copied in the first worksheet and thereafter from row row, excluding the totals

Your assistance in this regard will me most appreciated

Howard

******** ******************** ************************************************************************>Microsoft Excel - Newton.newvehicles.xls___Running: 12.0 : OS = Windows XP (F)ile (E)dit (V)iew (I)nsert (O)ptions (T)ools (D)ata (W)indow (H)elp (A)boutS19S20P23Q25R25S25=
OPQRSTU1969FOCUS 2.5 ST 5DR MAN     11,25026711,517newton19020682FIESTA 1.6D AMBIENTE 5DR 11,36028111,641newton24021       22       23Total Units19     24       25Total Value 213,8605,045218,905  Newton.newvehicles 
[HtmlMaker 2.42] To see the formula in the cells just click on the cells hyperlink or click the Name box
PLEASE DO NOT QUOTE THIS TABLE IMAGE ON SAME PAGE! OTHEWISE, ERROR OF JavaScript OCCUR.

I have this huge code that started off as a macro, then was combined with other macros and bits of coded gleaned from the board (see posts under "Help with Monster Macro - Auto Fill" to see the initial q&a). Everything works perfectly, but I know there is a more efficient way of writing this...I just don't know how to do it.

The code is below. Bascially what I am doing is downloading data from two separate sources into two worksheets in the same workbook, normalizing the data in the worksheets, then copying the data from both normalized sheets into one sheet which is later uploaded to a database. If anyone has any input, I'd really appreciate it....I know there are a lot of "select" and other things that can be simplfied, but I'm not a VB expert. Everything I know came from this board.

Thanks!!

Code:
 
Sub Test()
Dim Limit As Long, c As Long
Dim r As Range
 
Sheets("CS ODIN Upload").Select
Cells.Select
Selection.ClearContents
 
Sheets("BW Download").Select
Rows("1:37").Delete Shift:=xlUp
 
With Rows(1)
.Replace What:="*Overall Result*", Replacement:="", LookAt:=xlPart
.SpecialCells(4).EntireColumn.Delete
End With
 
With Sheets("BW Download")
Limit = .UsedRange.Rows.Count
.Columns("A:D").Insert Shift:=xlToRight
Range("A1") = "Check"
Range("B1") = "Benefitor"
Range("C1") = "ODIN Benefitor"
Range("D1") = "Work Group"
 
For Each r In .Range("B2:B" & Limit)
r.FormulaR1C1 = "=VLOOKUP(RC[3],BLT!BLT,2)"
Next r
For Each r In .Range("C2:C" & Limit)
r.FormulaR1C1 = "=LEFT(RC[-1],2)&IF(MID(RC[-1],3,1)>""1"",""81"",""11"")"
Next r
For Each r In .Range("A2:A" & Limit)
r.FormulaR1C1 = "=IF(VLOOKUP(RC[4],BLT!BLT,1)=RC[4],""True"",""False"")"
Next r
For Each r In .Range("D2:D" & Limit)
r.Value = "GHOST"
 
Range("G1") = "OCT"
Range("H1") = "NOV"
Range("I1") = "DEC"
Range("J1") = "JAN"
Range("K1") = "FEB"
Range("L1") = "MAR"
Range("M1") = "APR"
Range("N1") = "MAY"
Range("O1") = "JUN"
Range("P1") = "JUL"
Range("Q1") = "AUG"
Range("R1") = "SEP"
 
Next r
.Range("a:a").AutoFilter Field:=1, Criteria1:="True"
.Range("b:d,g:r").SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("CS ODIN Upload").Range("A1")
 
.Range("a:a").AutoFilter Field:=1, Criteria1:="False"
.Range("d:r").SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Fallout").Range("A1")
 
Selection.AutoFilter Field:=1
Cells.Select
Selection.Delete Shift:=xlUp
Sheets("CS ODIN Upload").Select
Range("A1").Select
Sheets("CT ODIN Upload").Select
Cells.Select
Selection.ClearContents
Sheets("CDW Download").Select
Range("A1").Select
 
Rows("1:2").Select
Selection.Delete Shift:=xlUp
 
Dim lastrow As Long, i As Long, ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
 
With ws
On Error Resume Next
.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
.Columns(4).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = lastrow To 1 Step -1
If .Range("A" & i).Value = 0 Or .Range("D" & i).Value = "N/A" Then .Rows(i).Delete
Next i
End With
 
Next ws
Columns("A:B").Select
Selection.Insert Shift:=x1Right
Range("A1") = "Benefitor"
Range("B1") = "ODIN Benefitor"
 
Range("A2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[2],4)"
Selection.AutoFill Destination:=Range("A2:A" & Range("d" & Rows.Count).End(xlUp).Row)
 
Range("B2").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],2)&IF(MID(RC[-1],3,1)>""1"",""81"",""11"")"
Selection.AutoFill Destination:=Range("b2:B" & Range("d" & Rows.Count).End(xlUp).Row)
 
Columns("D:D").Select
Selection.Delete Shift:=x1Left
 
Range("D1").Select
Range("D1") = "Work Group"
 
With Rows(1)
.Replace What:="*Total*", Replacement:="", LookAt:=xlPart
.SpecialCells(4).EntireColumn.Delete
End With
 
Range("a:b,d:p").Copy Destination:=Sheets("CT ODIN Upload").Range("A1")
 
Cells.Select
Selection.Delete Shift:=xlUp
Sheets("CT ODIN Upload").Select
Range("A1").Select
Sheets("Monthly Hours").Select
Cells.Select
Selection.Delete Shift:=xlUp
 
Sheets("CS ODIN Upload").Select
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Sheets("Monthly Hours").Select
Range("A1").Select
ActiveSheet.Paste
 
Sheets("CT ODIN Upload").Select
Range(("A2"), ActiveCell.SpecialCells(xlLastCell)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Monthly Hours").Select
Range("A1").End(xlDown).Select
ActiveSheet.Paste
 
Range("A1").CurrentRegion.Select
Selection.Replace What:="", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
End With
End Sub


Hi

I am trying to create a macro that will first enter the current time (once I click any key combination, say CTRL+Q) and then lock that particular cell.

Now, this is what I really want to do...

In Cell A1, there will be Out Time for the break, In Cell B1, it will be In Time, Cell C1 should calculate the difference between the Out Time and In Time. Note, some breaks may be spread over two calendar days.

Thanks

Khalid

Hello,

I'm presenting a class on Macros in Excel 2007 this week, and I have a sample file that includes a simple macro that moves a record from one sheet to another.

Essentially it's a list of hiking trails, and when one trail record (1 row by 8 columns) is selected, the macro moves it to the first available blank row on the next sheet.

I'm showing this class how to record their own macros, and how every click and keystroke is recorded for playback later. I'm not showing them how to write the macro in VB. I HAVE the "solution" file containing the macro, but here's my problem... I understand the language of all the macro steps except one... 5th step down in the attached code... "ActiveCell.Offset(1, 0).Range("A1").Select"

=================
Selection.Copy
Sheets("Travelled Trails").Select
Range("A1:H1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Range("A1:H1").Select
Sheets("Untravelled Trails").Select
Application.CutCopyMode = False
Selection.EntireRow.Delete
Range("A1:H1").Select
End Sub
=================

What I need to know is this... what is the keystroke combination / command that gets me that VB ebtry? I used Ctrl+DownArrow to get the line just before it, but simply hitting downarrow once more (to get to the first blank row) causes me to get...

Range("A3").Select

...in the code the first time I record it. That's not going to work, as every time I move one of those records from the first sheet, it should go to the next blank row. When that A3 line is there, the previous record pasted into row 3 gets pasted over every time.

Hope this makes sense... I hate not knowing how something works before I have to TEACH it!

Thanks,

I have a spreadsheet that is downloaded from an accounting system and requires extensive editing to be normalized before it is combined with data in another database. To normalize the data in a simple manner, I use the following macro:

Sub All()
'
' All Macro
'
'
Rows("1:37").Select
Selection.Delete Shift:=xlUp
Sheets("DL").Select
Columns("A:D").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
ActiveCell.FormulaR1C1 = "Check"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Benefitor"
Range("C1").Select
ActiveCell.FormulaR1C1 = "ODIN Benefitor"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Work Group"
Range("B2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[3],BLT!BLT,2)"
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=LEFT(RC[-1],2)&IF(MID(RC[-1],3,1)>""1"",""81"",""11"")"
Range("A2").Select
ActiveCell.FormulaR1C1 = _
"=IF(VLOOKUP(RC[4],BLT!BLT,1)=RC[4],""True"",""False"")"
Range("D2").Select
ActiveCell.FormulaR1C1 = "GHOST"
Selection.AutoFill Destination:=Range("D2:D176")
Range("D2:D176").Select
Range("A2:C2").Select
Selection.AutoFill Destination:=Range("A2:C176")
Range("A2:C176").Select
Range("a:a").AutoFilter Field:=1, Criteria1:="True"
Range("b:d,g:r").SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("ODIN Upload").Range("A1")

End Sub

It works great, however I would like to not limit my cell ranges for the auto fills. I would like to auto fill to the end of the data, which changes with every download (additional rows).

Any ideas?

Hi, I'm a bit confused regarding this macro and would appreciate any help given.

I have two macros that I've attached two macros to, instead of writing the same code again I'm using a third button that calls both functions for an entire range. This has lead to some errors though,

It seems that sometimes the macro will fail to call the second macro, is it possible or only my imagination?

Sub UpdateStructures()
'
' Loads and saves all structures
' Macro developed 2008-05-21 by Antonio Andersen Toledo
'
Application.ScreenUpdating = False
Dim Cell As Range
For Each Cell In Worksheets("Structures").Range("B3:B" & Worksheets("Structures").Range("A65535").End(xlUp).Row)
Cells(3, 1).Value = Cell.Value
Cells(5, 1).Value = Cell.Offset(0, 2).Value

Call GetStructures

Call SaveStructures

Next
Application.ScreenUpdating = True
'
End Sub

In the macro GetStructures I have the following code that I suspect might be cause the macro to skip a row sometimes, TRC = target row:

'Exits and removes structures if string was not found
If MatchString LookupString Then
MsgBox ("The parma/department combination " & LookupString & " was not found, removing bad structures")
Do Until TRC = TLR
If Worksheets(TS).Range("B" & TRC).Value = Range("A3").Value And Worksheets(TS).Range("D" & TRC).Value = Range("A5").Value Then
Worksheets(TS).Range("A" & TRC).EntireRow.Delete Shift:=xlUp
TRC = TRC - 1
End If
TRC = TRC + 1
Loop
Exit Sub
End If

Thanks alot

Hello All.
I'm looking for a macro that can sort emails by 2 very distinct ways,
with 1 special find function as well. Not too much eh?

I shall explain;

Below I'll list a small email list (Sample data) for clarity;
Code:
10info@pmarketingco.com
10jackwell@sbglobal.net
10john_well@sbglobal.net
10johnmrow@hotmail.com
0joyrush@sbglobal.net
130kenneth.mil@sosplan.com
orders@photpln.co.uk
prp@aol.com
rocking@sthshore.com
sal@smtosno.com
20sales@millonassman.com.cy
(As a note; all emails above have been altered from originals).

1st Sort Macro explained
=========================
This is what I'd love to be able to do.
All emails would be in ColA (From A3 downwards)
I click an assigned macro button and a pop up window would appear.

This gives me 3 choices of inputs.
If I type in for example the symbol "@" and hit enter it would re sort
the list A-Z with everything AFTER the @ symbol.

So, in the above data, the list would finish up looking like;
Code:
prp@aol.com
10johnmrow@hotmail.com
20sales@millonassman.com.cy
orders@photpln.co.uk
10info@pmarketingco.com
10jackwell@sbglobal.net
10john_well@sbglobal.net
0joyrush@sbglobal.net
sal@smtosno.com
130kenneth.mil@sosplan.com
rocking@sthshore.com
So, all the above is now sorted A-Z after the @ symbol.
If some are duplicates after the "@", them it would need to look
before the "@" to finish the sorting A-Z.
============================================================

2nd Sort Function
=================

The 2nd sort function is a variation on this.
I would click the macro button.
The pop up window would appear. I would enter in for example
"."(WITHOUT the @ symbol).
(As a note; the popup within the macro could say something like;
Type 0 for "@" type 1 for "." 2 for "Exact Find"),,,, if this is easier.

This would then mean the whole email
list would be sorted by the ending email extensions, ie,
.com/.uk/.gov/.net etc, sorted all A-Z.

So, in the above sample data, the list would look like;

Code:
prp@aol.com
10johnmrow@hotmail.com
10info@pmarketingco.com
sal@smtosno.com
130kenneth.mil@sosplan.com
rocking@sthshore.com
20sales@millonassman.com.cy
10jackwell@sbglobal.net
10john_well@sbglobal.net
0joyrush@sbglobal.net
orders@photpln.co.uk
So it's .com/.cy/.net/.uk
For this sort the macro has to look at the data before the ending "." also,
to keep it in A-Z order. it would look at all data after the "@" 1st, so the list
is sorted by ;
"." 1st
data after the "@" 2nd
Finally data before the "@" 3rd to keep it in A-Z order.

As a note, in my large unfiltered email lists (Maybe 50,000 rows of emails or more,
sometimes there is a ".jpeg" extension (Obviously not an email but a picture), so with
this sort function I can easily find all ".jpegs" so they can be deleted.

===============================================================

3rd Function (Exact Find)
=========================

If I click the assigned macro button, a pop up would appear,
I type the number "2" Which would activate the "Exact Find" Function
and type sosplan.com

This would then return all emails in my list in Col A (From A3 downwards)
into Col C (From C3 downwards) that had "sosplan.com" as part of the email address
and list these into ColC.

As a note;
I do have a macro written by Jindon which is excellent which does find words ending with,
which I will list now, as it's probably 50% or more of what I'm looking for,
but it doesn't have the 2 sorting functions.

here's Jindon's "Find Words Ending With" macro;

Code:
Sub Find_Words_Ending_In()
Dim sTime As Single, res As String, x As Range
Dim y, mySearch As String
res = InputBox("Enter word & , then 1 for Exact Match or 0 for Ending With")
If (res = "") + (res = "False") Then Exit Sub
y = Split(res, ",")
If UBound(y)  1 Then msg = "Invalid entry"
If (Int(Val(y(1))) < 0) + (Int(Val(y(1))) > 1) Then msg = "Invalid Entry"
If Len(msg) Then
    MsgBox msg
    Exit Sub
End If
y(1) = Int(Val(y(1)))
mySearch = IIf(y(1) = 1, " ", "") & Trim(y(0))
Range("c3:c" & Rows.Count).ClearContents
sTime = Timer
On Error Resume Next
With Range("a3", Range("a" & Rows.Count).End(xlUp))
     msg = "Total scanned : " & .Rows.Count
     With .Offset(, 2)
          .NumberFormat = "General"
          .FormulaR1C1 = "=if(right(rc[-2]," & Len(mySearch) & ")=" & Chr(34) & mySearch & Chr(34) & ",rc[-2],False)"
          Set x = .SpecialCells(-4123, 4)
          .Value = .Value
          x.Delete xlShiftUp
          msg = msg & vbLf & "Found " & WorksheetFunction.CountA(.Cells) & " records Ending in  " & res
     End With
End With
MsgBox msg & vbLf & "Time Elapsed[s] : " & Format(Timer - sTime, "#,##0.000") & " sec"
End Sub
The above macro really is great, but if I could combine that with the 2 sort functions, this would really
make the Email Sort and Find macro special, a multi purpose email macro on steroids!
I hope all the above has made sense, and hopefully is viable.
Many thanks for all your time.
John Caines

Hi - I need to take the data from 4 different sheets and combine into a summary sheet. The columns are the same, but the number of rows will vary.

Sheet 1
row 1 - 1001
row 2 - 2001
row 3 - 3001

Sheet 2
row 1 - 4001
row 2 - 5001

Sheet 3
row 1 - 6001
row 2 - 7001
row 3 - 8001
row 4 - 9001

Sheet 4
row 1 - 10001

So the summary would be
row 1 - 1001
row 2 - 2001
row 3 - 3001
row 4 - 4001
row 5 - 5001
row 6 - 6001
row 7 - 7001
row 8 - 8001
row 9 - 9001
row 10 - 10001

Can this be done with a formula? I'm using this spreadsheet with Xcelsius, so no pivot tables, no macros and no VBA code.

Hello everyone

I have a macro (see code below) that helps me combine multiple sheets from different workbooks into one.

It work fantastically well but i need to make a change to it so that i can use it in my new format.

This macro is set to take each file considering that the first row is the header however my file now an header with 3 rows which mean the data only start at row 4.

Additionally please note that
- row 1 is blank
- row 2 has merge cells (sub column header)
- row 3 has for each column a header
- row onward my data

I have tried to update the code but I keep getting an error which I cannot understand

Would someone know how to update my code so that it works on my new configuration? I need to ensure that the consolidated file takes the first 3 rows as header and then consolidate the data from all the files
(all files have the same header / data structure

Thx a lot

Here is the original code

Sub CombineWorksheets()
Dim strFileName As String
Dim strMyFileName As String
Dim strWorkbookPassword As String
Dim strWorksheetPassword As String
Dim strWorksheetLeaveAlone As String
Dim intHeader As Integer
Dim strWorkbookDirectory As String
Dim intPasteFormats As Integer
Dim intRow As Integer
Dim intRow2 As Integer
Dim wkb As Workbook
Dim wks As Worksheet
'Define passwords and directory
strWorkbookDirectory = InputBox("Please enter the full path of the directory that the files you want to combine are currently sitting. Note that this directory should only contain the files you want to combine, and each file should be in the same order of columns and same format.", "Directory")
strWorkbookPassword = InputBox("What is the password to open each file? (Leave blank if none)", "File Password")
strWorksheetPassword = InputBox("What is the password to open each file? (Leave blank if none)", "Sheet Password")
intPasteFormats = MsgBox("Do you want to include all the formatting?", vbYesNo, "Formats")
intHeader = 0
' Define which sheet to leave alone on each file
strWorksheetLeaveAlone = "Rates"
'Stop screen showing everything - makes it faster
Application.ScreenUpdating = False
'set strMyFileName as the name of this spreadsheet (so we can avoid it in the code)
strMyFileName = ActiveWorkbook.Name
strMySheetName = ActiveSheet.Name
'Clear the sheet
Cells.Select
Selection.ClearContents
'Find first spreadsheet in the directory we need to search. The function
'DIR gets the name of the next file in the relevant directory
strFileName = Dir(strWorkbookDirectory & "/*.xls")
'Loop until all files have been checked
Do Until strFileName = ""
If (UCase(Right(strFileName, 3)) = "XLS") And (strFileName strMyFileName) Then

Application.Workbooks.Open (strWorkbookDirectory & "" & strFileName), , True, , strWorkbookPassword
Workbooks(strFileName).Activate
Workbooks(strFileName).Unprotect strWorksheetPassword
For Each wks In ActiveWorkbook.Worksheets
If wks.Name strWorksheetLeaveAlone Then
If intHeader = 0 Then
Rows("1:1").Copy
Workbooks(strMyFileName).Worksheets(strMySheetName).Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
If intPasteFormats = 6 Then Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
intHeader = 1
End If
wks.Activate
wks.Unprotect strWorksheetPassword
'This is the bit that copies the correct rows. I have assumed that
'the data starts on row 2 and that all the cells in column A have
'something in them. If they don't the ctrl down arrow won't go right to
'the bottom.
Range("A1").Select
Selection.End(xlDown).Select
intRow = ActiveCell.Row
Rows("2:" & intRow).Copy

'This finds the bottom of the sheet and pastes the data into
'the row below
Workbooks(strMyFileName).Activate
intRow = ActiveSheet.UsedRange.Rows.Count
If intRow = 0 Then
Range("A1").Select
Else
Range("A" & intRow + 1).Select
End If
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
If intPasteFormats = 6 Then Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'This empties the clipboard. If you don't do this, when you try to close
'the spreadsheet you'll keep getting the 'excel has data on the clipboard,
'do you want to make it available to other applications?' message
Application.CutCopyMode = False
End If
Next wks
Workbooks(strFileName).Close False
End If
'move onto the next file in the directory (which may not be an xls, hence the check above)
strFileName = Dir()
Loop
'put screen updating back on. This will be the first time you see anything actually happening
Application.ScreenUpdating = True
End Sub

Hi there,

I'm looking to write a macro that will copy a report from Excel to Outlook and keep the same formatting etc. Is this possible?

I have searched the forum for something similar but they only seem to cover copying text which is no good for me as my report is a combination of text and tables.

All help appreciated.

Thanks!

Wondered if there are any Excel macro gurus out there who may be able to help me save a lot of time and finish off this macro I've been struggling on for a financial spreadsheet....

Basically what I'm trying to do is create a flexible business model that you can add new business units to as required.

The top sheet combines all of these individual units together so you can view how your combined business looks.

What I need to do is take the formula that is already present in each cell of the top sheet, and adjust it so that it adds in the new sheet.

So in the VB code for example, I have for one cell:

Range("D92").Select
ActiveCell.FormulaR1C1 = "=FirstUnit!R[377]C+NewUnit!R[377]C"

However this is not good enough as it always uses the same formula each time so when I add the third unit, the formula will not be changed.

What I want it to look like would be as below

Range("D92").Select
ActiveCell.FormulaR1C1 = "=FirstUnit!R[377]C+NewUnit!R[377]C+ThirdUnit!R[377]C"

and then the next time

Range("D92").Select
ActiveCell.FormulaR1C1 = "=FirstUnit!R[377]C+NewUnit!R[377]C+ThirdUnit!R[377]C+FourthUnit!R[377]C"

hopefully that explains what I'm trying to do....

What I need is some way of telling VB to take the formula currently in the cell and then add the extra cell

e.g.

Range("D92").Select
ActiveCell.FormulaR1C1 = EXISTING_FORMULA+"+NewUnit!R[377]C"

Any suggestions? It's a simple example, but once I understand how to get it to take the existing formula and then apply the necessary modification I can apply it as necessary. Cheers

I would like to be able to open multiple .DAT files and combine them into a single sheet. Currently I have a single macro that will import one and set the column widths, tab spacing, etc. I need to open others but ultimately have all of the in a single sheet of a workbook. Here is the current macro that I received from a friend. Is there a better method or a way to modify this macro to allow for multiple files of the same format to be combined?

Sub Openfile_copy_paste_close()
Dim LastRow As Long
Dim origwb As Object 'original file
Set origwb = ActiveWorkbook
Dim newsheet As Worksheet 'this will be newsheet in orig file

Dim otherfileName As String
Application.ScreenUpdating = False
ChDir "hbopw-amr1hbpwamr"
otherfileName = Application.GetOpenFilename(FileFilter:="DAT Files (*.dat),*.dat", _
Title:="Please choose a file. This file's contents will be copied into the original file.", _
MultiSelect:=False)

'Note the above does not open the file, just identifies it. The open is below, assuming they chose something.
If otherfileName = "False" Then GoSub No_File_Chosen
' MsgBox "Opening file: " & otherfileName

Workbooks.Open otherfileName, Format:=2
Dim otherfile As Object
Set otherfile = ActiveWorkbook 'capture otherfile as an object because some calls will not work with string datatype.
'Cells.Select
'Selection.Copy
'UsedRange.Copy
Range("A2").Select
Selection.CurrentRegion.Copy
Windows(origwb.Name).Activate
'Add new sheet to orig-file to receive paste:
'Set newsheet = Sheets.Add(Type:=xlWorksheet)
'newsheet.Name = "sheet name" 'Could choose to rename the sheet if desired

Range("A2").Select
'Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False 'eliminates prompt for keeping the copy-buffer on close
otherfile.Close savechanges:=False

Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(12, 1), Array(22, 1), Array(24, 1), Array(35, 1), Array(44, 1), _
Array(45, 1), Array(50, 1), Array(59, 9), Array(68, 9), Array(77, 9), Array(86, 9), Array( _
95, 9), Array(104, 9), Array(113, 9), Array(122, 9), Array(131, 9), Array(140, 9), Array( _
147, 1), Array(165, 1), Array(175, 1))
Cells.Select
Selection.Sort Key1:=Range("H1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Range("A1").Select
ActiveCell.FormulaR1C1 = "MXU_ID"
Range("B1").Select
ActiveCell.FormulaR1C1 = "PORT#"
Range("C1").Select
ActiveCell.FormulaR1C1 = "DATE"
Range("D1").Select
ActiveCell.FormulaR1C1 = "TIME"
Range("E1").Select
ActiveCell.FormulaR1C1 = "STATUS"
Range("F1").Select
ActiveCell.FormulaR1C1 = "QC_CODE"
Range("G1").Select
ActiveCell.FormulaR1C1 = "READING"
Range("H1").Select
ActiveCell.FormulaR1C1 = "ACCOUNT#"
Range("I1").Select
ActiveCell.FormulaR1C1 = "METER#"
Range("J1").Select
ActiveCell.FormulaR1C1 = "ROUTE_CYCLE"

Range("A1:J1").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With

Columns("C:C").Select
Selection.NumberFormat = "mm/dd/yy"
Columns("A:J").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With

'Selection.AutoFilter
'Selection.AutoFilter Field:=2, Criteria1:="0"
Selection.RowHeight = 12.75

ActiveSheet.Shapes("Button 1").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 13.5
Selection.ShapeRange.Width = 51#
ActiveSheet.Shapes("Button 2").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 13.5
Selection.ShapeRange.Width = 51#

'Rows("1:1").RowHeight = 21

Range("A2").Select
Application.ScreenUpdating = True

Exit Sub

No_File_Chosen:
MsgBox "You did not select any file. Nothing will be imported."
End Sub

Hi,
I have a pivot table in a workbook called "InvReport". I want to create a button that updates an external query in another workbook called "InvReportData" and then update the pivot tables in my active workbook (InvReport). Do I have to have the macro actually open the "InvReportData" workbook to update the query? I want this to be as seemless as possible.

Here is the code I have that updates "InvReportData". Can someone help me to set this up so it will run from a form button in "InvReport" workbook?

Thanks,

Code:
Sub UpdateandCombineSheets()


'refresh query open, import and stock
    Workbooks("InvReportDate").Activate
    Sheets("open").Select
    Range("e4").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    
    Sheets("import").Select
    Range("e4").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    
    Sheets("stock").Select
    Range("e4").Select
    Selection.QueryTable.Refresh BackgroundQuery:=False
    
'Combines open, import and stock tabs into on Summary tab

'Original code by jonmo1
' http://www.mrexcel.com/forum/showthread.php?t=304185
'
' Modified 04/01/2008 by stanleydgromjr

    Dim Dsheet
    Dim ws
    Dim LR, LR2
    Worksheets(1).Select
    On Error Resume Next
    Sheets("Summary").Select
    If Err Then
        Worksheets.Add().Name = "Summary"
    Else
        Cells.Clear
        Application.CutCopyMode = False
    End If
    On Error GoTo 0
    Set Dsheet = ActiveSheet
    For Each ws In Sheets
        If ws.Name  "Summary" Then
            ws.Rows("1:1").Copy Dsheet.Range("A1")
            LR = ws.Cells(Rows.Count, "A").End(xlUp).Row
            LR2 = Dsheet.Cells(Rows.Count, "A").End(xlUp).Row
            ws.Rows("2:" & LR).Copy Dsheet.Range("A" & LR2 + 1)
        End If
    Next ws
End Sub


Greetings - I have a variety of macros assigned to buttons on a custom tool bar. This tool bar is attached to a specific workbook and this workbook get regenerated each month witha new file name (the number in red indicates the value that changes each month). Each month I have to update all of the macros when I change the workbook name. Is there a phrase I can add to the code like ".this workbook" or "me" that would do that for me? I have tried some of the ones I use on my userforms and I haven't been able to quite hit the correct combination. Thanks

Here is an example of the code that I currently have assigned to a custom button:

'Daily Checklist -EpiMSA - 0276 rev14.xls'!CanisterChange

My main problem with this macro is that it is changing any text in a particular cell that contains the symbol (') : & # 3 9 ;
Please note that the & # 3 9 ; should all be together without spaces, when I am submitting the thread it is changing the combination to ' , so i figure the combination has something to do with code !

Example

David's is changing to: David & # 3 9 ;
Ect

The code is very long and it does need tidying as it flickers around a lot and takes approx 4 seconds to complete, however the macro does work perfectly apart from the error explained above. Its probably too complicated to find out what is causing it as the code is so long, however just a little help tidying the code would be great to stop the long flicker.

Full code is:

Sub combined_code_us()

Columns("A:A").EntireColumn.AutoFit
Range("C:C,G:G,H:H,I:I,M:M,R:R,S:S,T:T").Select
Range("T1").Activate
Selection.Delete Shift:=xlToLeft
Columns("C:R").Select
Selection.Cut Destination:=Columns("AA:AP")
Columns("AH:AH").Select
Selection.Cut Destination:=Columns("C:C")
Columns("C:C").Select
Columns("AJ:AJ").Select
Selection.NumberFormat = "0"
Selection.Cut Destination:=Columns("G:G")
Range("O36").Select
Columns("AI:AI").Select
Selection.Cut Destination:=Columns("D:D")
Columns("D:D").Select
Columns("AG:AG").Select
Selection.Cut Destination:=Columns("F:F")
Columns("F:F").Select
Columns("AD:AD").Select
Selection.Cut Destination:=Columns("H:H")
Columns("H:H").Select
Columns("AE:AF").Select
Selection.Cut Destination:=Columns("J:K")
Columns("J:K").Select
Columns("AB:AC").Select
Selection.Cut Destination:=Columns("L:M")
Columns("L:M").Select
Columns("AA:AA").Select
Selection.Cut Destination:=Columns("N:N")
Columns("N:N").Select
Columns("AK:AP").Select
Columns("AK:AP").Cut Destination:=Columns("O:T")
Range("C6").Select
Columns("D:D").ColumnWidth = 34
Columns("D:D").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.ColumnWidth = 50.43
Columns("C:C").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("F:F").Select
With Selection
.HorizontalAlignment = xlFill
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("E1").Select
ActiveCell.FormulaR1C1 = "My Code"
Range("I1").Select
ActiveCell.FormulaR1C1 = "My Notes"
Columns("J:T").Select
With Selection
.HorizontalAlignment = xlFill
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("J:T").EntireColumn.AutoFit
Selection.ColumnWidth = 26.43
Selection.ColumnWidth = 27.57
Selection.ColumnWidth = 20.86
With Selection
.HorizontalAlignment = xlFill
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlFill
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.SmallScroll Down:=-42
Rows("1:1").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("C1").Select
Columns("F:F").ColumnWidth = 17.57
Columns("F:F").ColumnWidth = 20.29
Columns("F:F").ColumnWidth = 21
Columns("G:G").ColumnWidth = 12.14
Columns("J:J").ColumnWidth = 16.86
Columns("K:K").ColumnWidth = 14.14
Columns("L:L").ColumnWidth = 17.14
Columns("F:F").ColumnWidth = 15.57
Columns("D:D").ColumnWidth = 41.86
Columns("L:L").ColumnWidth = 17
Columns("M:M").ColumnWidth = 18.29
Range("A1").Select
Rows("1:1").RowHeight = 42
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("C:C").ColumnWidth = 9.43
Columns("C:C").ColumnWidth = 11
Columns("C:C").ColumnWidth = 11.14
Cells.Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("F:F").Select
Cells.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.RowHeight = 12.75
ActiveWindow.SmallScroll Down:=-18
Rows("1:1").Select
Selection.RowHeight = 33.75
Range("A2").Select
Range("A1:T115").Sort Key1:=Range("L2"), Order1:=xlAscending, Key2:=Range _
("M2"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
Cells.Replace What:="eBay ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("L:L").ColumnWidth = 17.29
Columns("G:G").EntireColumn.AutoFit
Columns("C:C").ColumnWidth = 9.57
Columns("C:C").ColumnWidth = 8.57
Columns("C:C").ColumnWidth = 7.86
Columns("H:H").ColumnWidth = 7.14
Columns("H:H").EntireColumn.AutoFit
Columns("H:H").ColumnWidth = 5.71
Columns("H:H").ColumnWidth = 6.57
Columns("I:I").ColumnWidth = 7
Columns("J:J").ColumnWidth = 15
Columns("J:J").ColumnWidth = 11.29
Columns("J:J").ColumnWidth = 10.71
Columns("J:J").ColumnWidth = 10
Rows("1:1").RowHeight = 42

Columns("G:G").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.ColumnWidth = 27.43
Selection.ColumnWidth = 24.86
Range("I1").Select
Windows("New Sales.xls").Activate
Windows("Download.csv").Activate
ActiveCell.FormulaR1C1 = "Date Sent"
With ActiveCell.Characters(Start:=1, Length:=9).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
Range("J1").Select
ActiveCell.FormulaR1C1 = "My Notes"
With ActiveCell.Characters(Start:=1, Length:=8).Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("K1").Select
Columns("I:I").ColumnWidth = 5.43
Columns("J:J").ColumnWidth = 5.14
Columns("O:O").Select
Selection.Insert Shift:=xlToRight
Columns("K:L").Select
Columns("O:O").Select
Selection.Insert Shift:=xlToRight
Columns("K:L").Select
Selection.Cut Destination:=Columns("O:P")
Columns("O:P").Select
Columns("K:L").Select
Selection.Delete Shift:=xlToLeft
Range("L3").Select
Columns("L:L").ColumnWidth = 15.14
Columns("L:L").ColumnWidth = 12
Columns("L:L").ColumnWidth = 13.57
Columns("K:K").ColumnWidth = 15
Columns("K:K").ColumnWidth = 17
Columns("K:L").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.ColumnWidth = 15.14
Selection.ColumnWidth = 13.29
Columns("M:M").ColumnWidth = 11.14
Range("K10").Select
Columns("G:G").ColumnWidth = 23.71
Columns("C:C").ColumnWidth = 8.57
Columns("C:C").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("2:2").Select
Selection.Insert Shift:=xlDown
Selection.RowHeight = 21
Range("A1:U1").Select
With Selection.Interior
.ColorIndex = 36
.Pattern = xlSolid
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.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 = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Columns("A:U").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.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 = xlThin
.ColorIndex = xlAutomatic
End With
Cells.Select
Range("A3").Select
Columns("O:O").Select
Selection.Insert Shift:=xlToRight
Columns("M:M").Select
Selection.Cut Destination:=Columns("O:O")
Columns("M:M").Select
Selection.Delete Shift:=xlToLeft
Columns("K:K").Select
Selection.Insert Shift:=xlToRight
Columns("N:N").Select
Selection.Cut Destination:=Columns("K:K")
Columns("N:N").Select
Selection.Delete Shift:=xlToLeft
Columns("L:L").Select
Selection.Insert Shift:=xlToRight
Columns("N:N").Select
Selection.Cut Destination:=Columns("L:L")
Columns("N:N").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").ColumnWidth = 37.71
Columns("D:D").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.ColumnWidth = 40.86
Columns("D:D").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.ColumnWidth = 34.29
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.SmallScroll Down:=-6
Columns("D:D").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlFill
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("D1").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A3").Select
End Sub

I have an request that comes up once an a while in my work environment. On occasion I will receive an Excel spreadsheet with a list of documents. The spreadsheet will have a beginning and ending document number in corresponding columns. I usually need to do two things with this information.
1. Identify any gaps in the number sequence
2. Consolidate the number series where no gaps exist.
For example:

I will get a spreadsheet that contains this information:

Begdoc# Enddoc#
200 240
241 266
270 288
289 300

What I want to do is to be able to ID the gap between 266 and 270, and combine the numbers that do not have gaps so it looks like this:

Begdoc# Enddoc#
200 266
270 300

I would like to be able to do this in two steps. Somtimes I just need to identify the gaps and somtimes I need to combine the consecutive number series.

Thanks in advance!

I am trying to run a macro that will summarize select data out of 35 different worksheets and combine the data into 2 columns on 1 worksheet.

Can someone please fix this so it will work...it pulls over only sheet names.

Help please!

Code:
Sub Cash_Summary()
    Dim Sh As Worksheet
    Dim Newsh As Worksheet
    Dim myCell As Range
    Dim ColNum As Integer
    Dim RwNum As Integer
    Dim Basebook As Workbook
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets("Cash_Summary").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Set Basebook = ThisWorkbook
    Set Newsh = Basebook.Worksheets.Add
    Newsh.Name = "Cash_Summary"
    RwNum = 1
    For Each Sh In Basebook.Worksheets
        If Sh.Name  Newsh.Name And Sh.Visible Then
            ColNum = 1
            RwNum = RwNum + 1
            Newsh.Cells(RwNum, 1).Value = Sh.Name
            For Each myCell In Sh.Range("B1,D1")
                ColNum = ColNum + 1
                Newsh.Cells(2, 2).Formula = _
                "='" & "Sh.Name" & "'!" & myCell.Address(False = False) = "$A$1"
            Next myCell
        End If
    Next Sh
    Newsh.UsedRange.Columns.AutoFit
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub