Free Microsoft Excel 2013 Quick Reference

Excel VBA Selection.Delete Shift:=xlToLeft

I have a table and in the column D there are values that could either
be "A" or "T".

What I would like is a macro that could go though each value in column
D and if

The value is "A" Then for that row would shift the data in the row
left...

Range("G4:H4").Select ' Not limited to row 4 but to that specific
row

Selection.Delete Shift:=xlToLeft

Else

If The value is "T" Then for that row would shift the data in the row
left...

Range("H4:J4").Select ' Not limited to row 4 but to that specific
row
Selection.Delete Shift:=xlToLeft

Is this doable?

Brenda...Many thanks.


Post your answer or comment

comments powered by Disqus
Hello,

Could someone explain to me what is the meaning of the VBA expression:
Selection.Delete Shift:=xlToLeft

Intuitively, I would suppose that it should delete the selection, but why
there is this "Shift" part coming after?

The whole part of the code I try to analyze goes like this (and it looks
like a big garbage for me):

(...)
Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Confirmations").Select
Range("BA22").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
Columns("BA:BD").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("BC:BD").Select
Selection.Delete Shift:=xlToLeft
Columns("BD:BF").Select
Selection.Delete Shift:=xlToLeft
Columns("BE:BZ").Select
Selection.Delete Shift:=xlToLeft
Range("BA22:BD55").Select
Selection.Copy
Range("A22").Select
ActiveSheet.Paste
(...)

In particular, I can't see what is the goal of selecting first BA:BD, then
BC:BD, then BD:BF and finally BE:BZ...
Is it me that don't understand something or the code should be written
differently? (hint: it's still functionning correctly and it is not deleting
the data pasted in BA22 (lines 4-8 of the code)).

Many thanks for any explanations!
Mark

I got a an excel file from a website which can dowload stock quotes from yahoo finance into an excel sheet. The file has a macro called GetData which retrieves the information. When I try to run the macro on my computer I get error 1004, but I tried running it on several other computers it works without any problem, which means the code is correct but there might be some setting/configuration that is missing on my computer. When I try to debug I find that the editor highlites the line below in red (apparently this is where the macro stops). All the computers including mine on which I tried the macro are running Windows XP and Excel 2003. I posted the code below and the link to dowload the file, and I hope someone can help me figure out what is the problem.

If anyone wants to view the whole file here is the link.

http://www.gummy-stuff.org/Excel/Yahoo3.xls

Any assistance is very much appreciated.

Sub GetData()
Dim QuerySheet As Worksheet
Dim DataSheet As Worksheet
Dim qurl As String
Dim i As Integer, iMax As Integer

Clear

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Set DataSheet = ActiveSheet

For iMax = 0 To 1000 Step 200

i = 7 + iMax
If Cells(i, 1) = "" Then
GoTo stopHere
End If

qurl = "http://download.finance.yahoo.com/d/quotes.csv?s=" + Cells(i, 1)
i = i + 1
While Cells(i, 1) "" And i < iMax + 207
qurl = qurl + "+" + Cells(i, 1)
i = i + 1
Wend
qurl = qurl + "&f=" + Range("C2")
Range("c1") = qurl

QueryQuote:
With ActiveSheet.QueryTables.Add(Connection:="URL;" & qurl, Destination:=DataSheet.Range("N7"))
.BackgroundQuery = True
.TablesOnlyFromHTML = False
.Refresh BackgroundQuery:=False
.SaveData = True
End With
Range("N7:N207").Select
Selection.TextToColumns Destination:=Range("N7"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1))

Range("N7:W207").Select
Selection.Copy
Cells(7 + iMax, 3).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

' Range("N7:W207").Select
' Selection.ClearContents
Next iMax
clearNames
'turn calculation back on
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
' Range("C7:H2000").Select
' Selection.Sort Key1:=Range("C8"), Order1:=xlAscending, Header:=xlGuess, _
' OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' Columns("C:C").ColumnWidth = 25.43
' Range("h2").Select

stopHere:
clearNames
Clear2
End Sub
Sub Clear()
'
' Clear Macro
' Macro recorded 23/01/2008 by pjPonzo
'
'
Range("C7:L1200").Select
Selection.ClearContents

End Sub
Sub Clear2()
'
' clear2 Macro
' Macro recorded 25/03/2008 by pjPonzo
'
'
Columns("N:AA").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select
End Sub

Sub doALL()
Sheets("Yahoo1").Select
GetData
Sheets("Yahoo2").Select
GetData
Sheets("Yahoo3").Select
GetData
End Sub
Sub clearNames()
With ThisWorkbook
For Each nQuery In Names
If IsNumeric(Right(nQuery.Name, 1)) Then
nQuery.Delete
End If
Next nQuery
End With
End Sub

Hello all,

I'm using a VBA routine that creates a copy of a worksheet under a different
filename. The routine needs to delete column (D) before saving the new file,
however column D passes through a group of merged cells (A1 through D1).
When the command reaches this point:
> Columns("D").Select
> Range("D2").Activate,
the entire range of cells from A are selected. I could use the mouse to
manually select column D and delete it, but why wont VBA perform in the same
manner.

Here is the entire sub if it helps:

Sub Create_ECP_Copy()
'
'
Dim Promo As String, Rev As String, FileName As String

'Build File Name from Global Header Section
Promo = Range("D7").Text
Rev = " Rev " + Range("D8").Text
FileName = "Storage Promo " + Promo + Rev + " for ECP.xls"

'Copy 'On Promotion' Page to New File and Rename
Sheets("On Promotion").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("D").Select
Range("D2").Activate
Selection.Delete Shift:=xlToLeft
ActiveWorkbook.SaveAs FileName:= _
"C:Documents and Settingssada1.AMERICASMy Documents" + FileName _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Windows("Master NSS Promotion Matrix.xls").Activate
Sheets("Global Set-Up Page").Select

End Sub

Any insight would be greatly appreciated.

--
Regards...

Hello all,

I'm using a VBA routine that creates a copy of a worksheet under a different
filename. The routine needs to delete column (D) before saving the new file,
however column D passes through a group of merged cells (A1 through D1).
When the command reaches this point:
> Columns("D:D").Select
> Range("D2").Activate,
the entire range of cells from A:D are selected. I could use the mouse to
manually select column D and delete it, but why wont VBA perform in the same
manner.

Here is the entire sub if it helps:

Sub Create_ECP_Copy()
'
'
Dim Promo As String, Rev As String, FileName As String

'Build File Name from Global Header Section
Promo = Range("D7").Text
Rev = " Rev " + Range("D8").Text
FileName = "Storage Promo " + Promo + Rev + " for ECP.xls"

'Copy 'On Promotion' Page to New File and Rename
Sheets("On Promotion").Copy
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("D:D").Select
Range("D2").Activate
Selection.Delete Shift:=xlToLeft
ActiveWorkbook.SaveAs FileName:= _
"C:Documents and Settingssada1.AMERICASMy Documents" + FileName _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Windows("Master NSS Promotion Matrix.xls").Activate
Sheets("Global Set-Up Page").Select

End Sub

Any insight would be greatly appreciated.

--
Regards...

Excel VBA – Deleting Blank Cells

I have a column of cells B5 to B46 and I wish to check each cell for a “0” (zero) and if true, delete that “0”.
There could be two ways: Start checking from B46 and work up, finding and deleting each “0”, when a value >0 is found the routine stops. Or work up or down deleting each “0” leaving any cells with text or values >0.

Thanks,
Sandy

This is a piece of code from a macro that i am altering. I keep getting an error when i get to the 2nd line.

Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
Any suggestions?

Hello all,

I'm stuck at some, for me, difficult coding issue in VBA - userforms. I am making a userform where there a 2 fields, 1 that is enabled (txtAC) and 1 disabled (txtACold). The field 'txtAC' is filled in with a number. This number is from an excelsheet. The txtACold is the same number, but this one doesn't change, only when the 'Edit' button has been clicked. This is done so that excel can count the difference between those values. Depending on if the value is changing negative or positive, rows have to be deleted or inserted.

For that matter, i have the following code:


	VB:
	
 cmdEdit_Click() 
     
    Sheets("Test").Activate 
    With ActiveSheet 
        Columns("A").Find(What:=txtPC, After:=Range("A3"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder _ 
        :=xlByRows, SearchDirection:=xlNext, MatchCase:=False).EntireRow.Cells(1, 1).Select 
        With ActiveCell 
            .Offset(, 4).Value = txtAC  End With 
             
            Set c = Columns("A").Find(What:=txtPC, After:=Range("A3"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder _ 
            :=xlByRows, SearchDirection:=xlNext, MatchCase:=False) 
            If Not c Is Nothing Then 
                With c 
                    Columns("A").Find(What:=txtPC, After:=Range("A3"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder _ 
                    :=xlByRows, SearchDirection:=xlNext, MatchCase:=False).EntireRow.Cells(1, 3).Select 
                End With 
                NextPC = ActiveCell.Offset(txtACold.Value, 0).Select 
                NextPC = ActiveCell.End(xlDown).Select 
                ActiveCell.Offset(-2, 0).Select 
                With ActiveCell 
                    If txtACold.Value > txtAC.Value Then 
                        .EntireRow.delete Shift:=xlUp 
                    ElseIf txtACold.Value < txtAC.Value Then 
                        ActiveCell.Offset(txtACold.Value - 1, 0).Select 
                        .EntireRow.Insert Shift:=xlDown 
                        .EntireRow.Cells(0, 3).Select 
                        With ActiveCell 
                            .Value = txtACold.Value + 1 
                        End With 
                    End If 
                End With 
            End If 
        End With 
         
        With txtACold 
            .Value = txtAC 
        End With 
         
    End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
As you can see, only 1 row is inserted or deleted in stead of all. I can't figure out how to do that.
Second, each time a row is inserted, a number has to be given to that row in column C. So if there are 2 rows added and there are 3 rows allready, the rows 4 and 5 should be named 4 and 5 in column C. When a row is inserted, it is pushing lower rows further to the bottom.

Anybody knows how to handle this?
Thanks!!

Hi,

I'm running a macro that opens another workbook and read data from it.How can I incorporate this code into my macro.Sorry i don't knwo VBA.


	VB:
	
Workbooks.Open Filename:="[COLOR="Yellow"][COLOR="Red"]C:Documents and SettingsmsimantbDesktopINFRACHEM_POLYMERS -
DON''T DELETE.xls]Sheet1[/COLOR][/COLOR]" 
 
 
UserGRP_MAcro Macro 
 ' Macro recorded 2009/05/19 by msimantb
 '
 
 '
Rows("1:3").Select 
Selection.Delete Shift:=xlUp 
Columns("A:B").Select 
Selection.Delete Shift:=xlToLeft 
Columns("B:E").Select 
Selection.Delete Shift:=xlToLeft 
Columns("A:A").EntireColumn.AutoFit 
Rows("2:2").Select 
Selection.Delete Shift:=xlUp 
Range("B1").Select 
ActiveCell.FormulaR1C1 = "Existing userGroup" 
Range("B2").Select 
Columns("B:B").EntireColumn.AutoFit 
ActiveCell.FormulaR1C1 = _ 
"=OFFSET('[INFRACHEM_POLYMERS - DON''T DELETE.xls]Sheet1'!R1C1,1,0)" 
Range("B2").Select 
ActiveCell.FormulaR1C1 = _ 
"=OFFSET('[INFRACHEM_POLYMERS - DON''T DELETE.xls]Sheet1'!R[-1]C1,1,0)" 
Range("B2").Select 
Selection.AutoFill Destination:=Range("B2:B59") 
Range("B2:B59").Select 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Good morning,
I have created a "template" for not-so-savvy Excel users to automatically create a pivotTable from data the user pastes in the file. A few of the users run Excel 97 and have not been able to use the template. I am trying (without having access to 97) to retro-fit my macro for them. I have already "fixed" my find/replace code and my TTC code, now the macro is generating Error 438 "Object Does not support this property or method" Any ideas how I can fix this for them?
Debug highlights this code:
Code:
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        PRange).CreatePivotTable TableDestination:= _
        "'Budget Pivot'!R1C1", TableName:="Budget Pivot", DefaultVersion:= _
        xlPivotTableVersion10
This is the complete code:
Code:
Sub Create_PivotTables()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Columns("F:F").Select
    Selection.TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
 
    Columns("F:H").Select
    Selection.NumberFormat = "General"
    Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Period"
    Range("G1").Select
    Selection.NumberFormat = "General"
    ActiveCell.FormulaR1C1 = "Year"
 
Last = Cells(Rows.Count, "A").End(xlUp).Row
For i = Last To 2 Step -1
If (Cells(i, "M").Value) = "WIRE PAYMENT" Then
Cells(i, "M").EntireRow.Delete
End If
Next i
For i = Last To 2 Step -1
If (Cells(i, "M").Value) = "WIRE/ACH PAYMENT" Then
Cells(i, "M").EntireRow.Delete
End If
Next i
    Columns("H:H").Select
    Selection.Style = "Currency"
 
    Columns("M:M").Select
Dim c As Range
        For Each c In Range([M2], Cells(Rows.Count, "M").End(xlUp))
            If c.Value Like "DHL*" Then c.Value = "DHL"
            If c.Value Like "*GRAINGER*" Then c.Value = "GRAINGER"
            If c.Value Like " ATT*" Then c.Value = "AT&T"
            If c.Value Like "AT&T*" Then c.Value = "AT&T"
            If c.Value Like "UPS*" Then c.Value = "UPS"
            If c.Value Like "KROGER*" Then c.Value = "KROGER"
            If c.Value Like "LOWES*" Then c.Value = "LOWES"
            If c.Value Like "LOWE'S*" Then c.Value = "LOWES"
            If c.Value Like "MEIJER*" Then c.Value = "MEIJER"
            If c.Value Like "OFFICE DEPOT*" Then c.Value = "OFFICE DEPOT"
            If c.Value Like "STAPLES*" Then c.Value = "STAPLES"
            If c.Value Like "AMOCO*" Then c.Value = "AMOCO"
            If c.Value Like "BEST BUY*" Then c.Value = "BEST BUY"
            If c.Value Like "BESTBUYCOM*" Then c.Value = "BEST BUY"
            If c.Value Like "TARGET*" Then c.Value = "TARGET"
            If c.Value Like "SHELL*" Then c.Value = "SHELL"
            If c.Value Like "WAL-MART*" Then c.Value = "WAL-MART"
            If c.Value Like "CORP EX*" Then c.Value = "CORP EX"
            If c.Value Like "CVS*" Then c.Value = "CVS"
            If c.Value Like "FEDEX*" Then c.Value = "FEDEX"
            If c.Value Like "THE HOME DEPOT*" Then c.Value = "THE HOME DEPOT"
            If c.Value Like "USPS*" Then c.Value = "USPS"
            If c.Value Like "WALGREEN*" Then c.Value = "WALGREEN"
            If c.Value Like "EXXONMOBIL*" Then c.Value = "EXXONMOBIL"
            If c.Value Like "DUNKIN*" Then c.Value = "DUNKIN"
            If c.Value Like "HARBOR FREIGHT TOOLS*" Then c.Value = "HARBOR FREIGHT TOOLS"
            If c.Value Like "MACY*" Then c.Value = "MACY'S"
            If c.Value Like "ARAMARK UNIFORM*" Then c.Value = "ARAMARK UNIFORM"
            If c.Value Like "ADVANCE AUTO PARTS*" Then c.Value = "ADVANCE AUTO PARTS"
            If c.Value Like "DOLRTREE*" Then c.Value = "DOLLARTREE"
            If c.Value Like "KMART*" Then c.Value = "KMART"
            If c.Value Like "XFR*" Then c.Value = "XFR"
            If c.Value Like "XFER*" Then c.Value = "XFR"
            If c.Value Like "BIG LOTS*" Then c.Value = "BIG LOTS"
            If c.Value Like "ACME MARKETS*" Then c.Value = "ACME MARKETS"
            If c.Value Like "ACO-HARDWARE*" Then c.Value = "ACO-HARDWARE"
            If c.Value Like "ALLTEL*" Then c.Value = "ALLTEL"
            If c.Value Like "APPLEBEE*" Then c.Value = "APPLEBEES"
            If c.Value Like "ARAMARK   *" Then c.Value = "ARAMARK"
            If c.Value Like "AUTO PARTS UNLIMITED*" Then c.Value = "AUTO PARTS UNLIMITED"
            If c.Value Like "AUTOZONE*" Then c.Value = "AUTOZONE"
            If c.Value Like "B AND B APPL*" Then c.Value = "B AND B APPL"
            If c.Value Like "BARNES & NOBLE*" Then c.Value = "BARNES & NOBLE"
            If c.Value Like "BATH & BODY WORKS*" Then c.Value = "BATH & BODY WORKS"
            If c.Value Like "B & H PHOTO*" Then c.Value = "B & H PHOTO"
            If c.Value Like "BATTERIES PLUS*" Then c.Value = "BATTERIES PLUS"
            If c.Value Like "BED BATH & BEYOND*" Then c.Value = "BED BATH & BEYOND"
            If c.Value Like "BELK*" Then c.Value = "BELK"
            If c.Value Like "BLOCKBUSTER VIDEO*" Then c.Value = "BLOCKBUSTER VIDEO"
            If c.Value Like "BORDERS BOOKS*" Then c.Value = "BORDERS BOOKS"
            If c.Value Like "BURGER KING*" Then c.Value = "BURGER KING"
            If c.Value Like "BUSCH'S*" Then c.Value = "BUSCH'S"
            If c.Value Like "CIRCUIT CITY*" Then c.Value = "CIRCUIT CITY"
            If c.Value Like "COMMUNITY COFFEE*" Then c.Value = "COMMUNITY COFFEE"
            If c.Value Like "COMPUSA*" Then c.Value = "COMPUSA"
            If c.Value Like "CRACKER BARREL*" Then c.Value = "CRACKER BARREL"
            If c.Value Like "D&W*" Then c.Value = "D&W"
            If c.Value Like "DOLLAR GEN*" Then c.Value = "DOLLAR GENERAL"
            If c.Value Like "DOMINOS*" Then c.Value = "DOMINOS"
            If c.Value Like "DOMINO'S*" Then c.Value = "DOMINOS"
            If c.Value Like "FELPAUSCH*" Then c.Value = "FELPAUSCH"
            If c.Value Like "FERGUSON ENT*" Then c.Value = "FERGUSON ENT"
            If c.Value Like "FOOD WORLD*" Then c.Value = "FOOD WORLD"
            If c.Value Like "GIANT FOOD*" Then c.Value = "GIANT FOOD"
            If c.Value Like "GIANT-EAGLE*" Then c.Value = "GIANT-EAGLE"
            If c.Value Like "gempler*" Then c.Value = "gempler"
            If c.Value Like "GODFATHERS PIZZA*" Then c.Value = "GODFATHERS PIZZA"
            If c.Value Like "HAPPY HARRY'S*" Then c.Value = "HAPPY HARRY'S"
            If c.Value Like "HOBBY LOBBY*" Then c.Value = "HOBBY LOBBY"
            If c.Value Like "JIMMY JOHN*" Then c.Value = "JIMMY JOHNS"
            If c.Value Like "JOANN FABRIC*" Then c.Value = "JOANN FABRIC"
            If c.Value Like "KOHL*" Then c.Value = "KOHLS"
            If c.Value Like "LABSAFE*" Then c.Value = "LABSAFE"
            If c.Value Like "LEXIS-NEXIS*" Then c.Value = "LEXIS-NEXIS"
            If c.Value Like "MARATHON OIL*" Then c.Value = "MARATHON OIL"
            If c.Value Like "MCDONALD'S*" Then c.Value = "MCDONALD'S"
            If c.Value Like "MENARDS*" Then c.Value = "MENARDS"
            If c.Value Like "MOTION INDUSTRIES*" Then c.Value = "MOTION INDUSTRIES"
            If c.Value Like "NEWARK INONE*" Then c.Value = "NEWARK INONE"
            If c.Value Like "NORDSTROM*" Then c.Value = "NORDSTROM"
            If c.Value Like "O'CHARLEY'S*" Then c.Value = "O'CHARLEY'S"
            If c.Value Like "OFFICE MAX*" Then c.Value = "OFFICE MAX"
            If c.Value Like "OUTBACK*" Then c.Value = "OUTBACK"
            If c.Value Like "PANERA BREAD*" Then c.Value = "PANERA BREAD"
            If c.Value Like "PAPA JOHNS*" Then c.Value = "PAPA JOHNS"
            If c.Value Like "PIZZA HUT*" Then c.Value = "PIZZA HUT"
            If c.Value Like "POPEYE*" Then c.Value = "POPEYES"
            If c.Value Like "RADIO SHACK*" Then c.Value = "RADIO SHACK"
            If c.Value Like "RADIOSHACK*" Then c.Value = "RADIO SHACK"
            If c.Value Like "ROTO-ROOTER*" Then c.Value = "ROTO-ROOTER"
            If c.Value Like "ROTO ROOTER*" Then c.Value = "ROTO-ROOTER"
            If c.Value Like "RUBY TUESDAY*" Then c.Value = "RUBY TUESDAY"
            If c.Value Like "RED LOBSTER*" Then c.Value = "RED LOBSTER"
            If c.Value Like "RITE AID*" Then c.Value = "RITE AID"
            If c.Value Like "SAFEWAY STORE*" Then c.Value = "SAFEWAY STORE"
            If c.Value Like "SAFEWAY GIFT*" Then c.Value = "SAFEWAY STORE"
            If c.Value Like "SEARS ROEBUCK*" Then c.Value = "SEARS ROEBUCK"
            If c.Value Like "SHERWIN WILLIAMS*" Then c.Value = "SHERWIN WILLIAMS"
            If c.Value Like "SPEEDWAY*" Then c.Value = "SPEEDWAY"
            If c.Value Like "STARBUCKS*" Then c.Value = "STARBUCKS"
            If c.Value Like "SUBWAY*" Then c.Value = "SUBWAY"
            If c.Value Like "OLIVE GARD*" Then c.Value = "OLIVE GARDEN"
            If c.Value Like "TRACTOR-SUPPLY*" Then c.Value = "TRACTOR SUPPLY"
            If c.Value Like "TRADER JOE'S*" Then c.Value = "TRADER JOE'S"
            If c.Value Like "AOL*" Then c.Value = "AOL"
            If c.Value Like "VERIZON WIRELESS*" Then c.Value = "VERIZON WIRELESS"
            If c.Value Like "VERIZON WRLS*" Then c.Value = "VERIZON WIRELESS"
            If c.Value Like "VRZWRLSS*" Then c.Value = "VERIZON WIRELESS"
            If c.Value Like "WALMART*" Then c.Value = "WAL MART"
            If c.Value Like "WESCO*" Then c.Value = "WESCO"
            If c.Value Like "WINN-DIXIE*" Then c.Value = "WINN-DIXIE"
            If c.Value Like "ZEE MEDICAL*" Then c.Value = "ZEE MEDICAL"
            If c.Value Like "agent fee*" Then c.Value = "AGENT FEE"
            If c.Value Like "*AMTRAK*" Then c.Value = "AMTRAK"
            If c.Value Like "AMZ~*KINDLE*" Then c.Value = "AMZ*KINDLE"
            If c.Value Like "APPLIED IND TECH*" Then c.Value = "APPLIED IND TECH"
            If c.Value Like "ARBY'S*" Then c.Value = "ARBY'S"
            If c.Value Like "ATTM~**" Then c.Value = "AT&T"
            If c.Value Like "ATT~**" Then c.Value = "AT&T"
            If c.Value Like "BIG Y*" Then c.Value = "BIG Y FOODS"
            If c.Value Like "BJ WHOLESALE*" Then c.Value = "BJ WHOLESALE"
            If c.Value Like "BP OIL*" Then c.Value = "BP"
            If c.Value Like "GFS MKTPLC*" Then c.Value = "GFS MKTPLC"
            If c.Value Like "HESS*" Then c.Value = "HESS"
            If c.Value Like "OFFICEMAX*" Then c.Value = "OFFICE MAX"
            If c.Value Like "PCC SALES*" Then c.Value = "PCC SALES"
            If c.Value Like "WITTICHEN SUPPLY*" Then c.Value = "WITTICHEN SUPPLY"
            If c.Value Like "VZWRLSS*" Then c.Value = "VERIZON WIRELESS"
            If c.Value Like "QWEST COMMERCIAL*" Then c.Value = "QWEST COMMERCIAL"
            If c.Value Like "QWEST ~*COMMERCIAL*" Then c.Value = "QWEST COMMERCIAL"
            If c.Value Like "QWESTCOMM*" Then c.Value = "QWEST COMMERCIAL"
            If c.Value Like "SAKS FIFTH*" Then c.Value = "SAKS FIFTH AVE"
            If c.Value Like "SAFEWAY TIRE*" Then c.Value = "SAFEWAY TIRE"
            If c.Value Like "SEARS.COM*" Then c.Value = "SEARS ROEBUCK"
            If c.Value Like "*STOP & SHOP*" Then c.Value = "STOP & SHOP"
            If c.Value Like "xerox*" Then c.Value = "XEROX"
            If c.Value Like "XPEDX*" Then c.Value = "XPEDX"
        Next c
 
 
 
For i = Last To 2 Step -1
If (Cells(i, "M").Value) = "XFR" Then
Cells(i, "M").EntireRow.Delete
End If
Next i
 
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
myLastCell = Cells(lastRow, 24).Address
Set PRange = Range("A1:" & myLastCell)
Application.CommandBars("PivotTable").Visible = False
    Range("A1:" & myLastCell).Select
 
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        PRange).CreatePivotTable TableDestination:= _
        "'Budget Pivot'!R1C1", TableName:="Budget Pivot", DefaultVersion:= _
        xlPivotTableVersion10
    Sheets("Budget Pivot").PivotTables("Budget Pivot").AddFields RowFields:=Array( _
        "DEPARTMENT", "G/L ACCOUNT", "Orig Merchant Name"), ColumnFields:="Period", PageFields:="Year"
    Sheets("Budget Pivot").PivotTables("Budget Pivot").PivotFields("Transaction Amount"). _
        Orientation = xlDataField
    ActiveWorkbook.ShowPivotTableFieldList = False
 
Sheets("Budget Pivot").Select
    ActiveSheet.PivotTables("Budget Pivot").PivotFields("DEPARTMENT").NumberFormat _
        = "0_);(0)"
    Range("B7").Select
    ActiveSheet.PivotTables("Budget Pivot").PivotFields("G/L ACCOUNT"). _
        NumberFormat = "0_);(0)"
 
lastRow = Cells(Rows.Count, "F").End(xlUp).Row
myLastCell = Cells(lastRow, 26).Address
Range("D5:" & myLastCell).Style = "Currency"
Range("A:A").ColumnWidth = 26.29
Sheets("Data Dump").Select
Range("A1").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, Tab:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12 _
        , 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1), Array(18, 1), _
        Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array(23, 1), Array(24, 1))
 
Sheets("Budget Pivot").Select
    Cells.Select
    Cells.EntireColumn.AutoFit
Range("A1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Hi Everyone,

This is my first real VBA macro project and I am running into a few problems. The macro works great with small amounts of data, but when I am importing 1,000 rows into a data base of around 6-12,000 excel cant handle it and the program freezes.

Basically the macro...

1. Imports data from various spread sheets (anywhere from 10-45, anywhere from 500-1500 rows of total data)
-The data goes from column A-AJ
2. It adds a date stamp and highlights new entries
3. It deletes entries over 6 months old and also deletes duplicate entries
4. arranges data by date, newest first
5. There are also 9 pivot tables (1 actual table copied and pasted 8 times into different sheets)
6. It refreshes the pivot tables
7. It does some basic formating on the tables and saves the changes

I am not sure if I am just trying to accomplish to much with one macro, or if it is just very inefficiently written (probably both), or if the processing power of my PC is to blame. I have added a second method of deleting duplicates thinking that this was the source of the problem, but it doesnt seem to make it any slower or faster.

Code:
 
Private Declare Function SetCurrentDirectoryA Lib _
    "kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
    SetCurrentDirectoryA szPath
End Sub
Sub Collect_data_from_selected_files()
    'These Collect the data into the Pivot Data work sheet
    Dim MyPath As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant
    Dim FirstCell As String
    Dim R As Long
 
    'These delete the duplicate rows
    Dim cRow As Long 'Changed from Integer to Long b/c of runtime 6 error
    Dim cRow2 As Long 'Changed from Integer to Long b/c of runtime 6 error
    Dim cCol As Long 'Changed from Integer to Long b/c of runtime 6 error
    Dim foundDuplicate As Boolean
 
    Dim rngPasteTo As Range 'new
    Dim wksPasteTo As Worksheet
 
  'Delete entried older than 6 months
    Const cColumnAJ = 36
    Dim myRow As Integer
    Dim ws As Worksheet
    Dim vCellValue As Variant
 
    Dim myRowStr As String
    Dim myDate As Date
'Unhide Data Sheet
'Sheets("Data Sheet").Visible = True
    'Unlock sheet and change old data to no highlighting
        Sheets("Pivot Data").Select
        ActiveSheet.Unprotect
        Windows("WorkSheet.xls").Activate
        Range("A2").Select
        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        Selection.Interior.ColorIndex = xlNone
 
        Windows("WorkSheet.xls").Activate
        Worksheets("Pivot Data").Activate
        Range("A2").Select
        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        Selection.Interior.ColorIndex = xlNone
 
    'Delete entries older than 6 months
        'enumerate worksheets collection
        For Each ws In Worksheets
        'select worksheet
        Sheets("Pivot Data").Select
        'traverse cells, from last used cell to first one
        For myRow = ws.UsedRange.Rows.Count To 1 Step -1
                'get cell value
                vCellValue = ws.Cells(myRow, cColumnAJ)
                'is value a date?
                If IsDate(vCellValue) Then
                'compare date, delete row
                'If vCellValue = BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
                If Not sourceRange Is Nothing Then
                    SourceRcount = sourceRange.Rows.Count
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else
                        'Copy the file name in column A
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = FName(Fnum)
                        End With
                        'Set the destrange
                        Set destrange = BaseWks.Range("B" & rnum)
                        'we copy the values from the sourceRange to the destrange
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value
                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If
        Next Fnum
        BaseWks.Columns.AutoFit
    End If
ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    ChDirNet SaveDriveDir
 
    'Delete extra column and paste in the "WorkSheet" wrkbook, "data sheet" wrksheet
    Windows("Sheet1").Activate
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
 
    'High light in Red and Cut
    Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        With Selection.Interior
            .ColorIndex = 3
            .Pattern = xlSolid
        End With
    Selection.Cut
 
    'Select the sheet and cell, paste and add date stamp, then cut
    Windows("WorkSheet.xls").Activate
    Sheets("Data Sheet").Activate
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Cut
 
    'Paste to the first available row of pivot data sheet
    Set wksPasteTo = ActiveWorkbook.Sheets("Pivot Data")
    Set rngPasteTo = wksPasteTo.Range("A2")
    'Loop the process until it finds a blank cell
    Do Until rngPasteTo = ""
    Set rngPasteTo = rngPasteTo.Offset(1)
    Loop
    'Paste the content
    wksPasteTo.Paste rngPasteTo
    'Select the first cell in the sheet where you've just pasted to
    Application.GoTo ActiveWorkbook.Sheets("Pivot Data").Range("A1")
 
    'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        Windows("Sheet1").Select
 
        'ActiveSheet.Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
 
Dim LR As Integer
    Range("AK2").Select
        Selection.FormulaArray = _
          "=ISNUMBER(MATCH(1,(R1C3:R[-1]C[-34]=RC[-34])*(R1C24:R[-1]C[-13]=RC[-13])*(R1C26:R[-1]C[-11]=RC[-11]),0))"
 
     LR = Range("AJ" & Rows.Count).End(xlUp).Row
     Range("AK2").AutoFill Destination:=Range("AK2:AK" & LR), Type:=xlFillDefault
 
    Cells.Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=37, Criteria1:="TRUE"
    Cells.Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    Selection.AutoFilter Field:=37, Criteria1:="FALSE"
 
    Cells.Select
    Selection.AutoFilter
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlDown
    With Selection.Interior
        .ColorIndex = 16
        .Pattern = xlSolid
    End With
    Selection.Font.ColorIndex = 3
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "FIRM TYPE"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "JOB TITLE"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "COMPANY"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "ADDRESS LINE 1"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "ADDRESS LINE 2"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "ADDRESS_LINE_3"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "CITY"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "STATE"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "ZIP"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "FIRST NAME"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "LAST  NAME"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "PHONE AREA CODE"
    Range("M1").Select
    ActiveCell.FormulaR1C1 = "PHONE NUMBER"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "PHONE EXTENSION"
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "FAX AREA CODE"
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "FAX NUMBER"
    Range("Q1").Select
    ActiveCell.FormulaR1C1 = "FAX EXTENSION "
    Range("R1").Select
    ActiveCell.FormulaR1C1 = "EMAIL"
    Range("S1").Select
    ActiveCell.FormulaR1C1 = "WEB SITE"
    Range("T1").Select
    ActiveCell.FormulaR1C1 = "CATEGORIES "
    Range("U1").Select
    ActiveCell.FormulaR1C1 = "(******) REPORT NUMBER"
    Range("V1").Select
    ActiveCell.FormulaR1C1 = "REPORT VERSION NUMBER"
    Range("W1").Select
    ActiveCell.FormulaR1C1 = "PROJECT PUBLISH DATE"
    Range("X1").Select
    ActiveCell.FormulaR1C1 = "PROJECT TITLE"
    Range("Y1").Select
    ActiveCell.FormulaR1C1 = "PROJECT TYPE"
    Range("Z1").Select
    ActiveCell.FormulaR1C1 = "PROJECT ACTION STAGE"
    Range("AA1").Select
    ActiveCell.FormulaR1C1 = "PROJECT VALUATION (HIGH VALUE)"
    Range("AB1").Select
    ActiveCell.FormulaR1C1 = "PROJECT BID DATE"
    Range("AC1").Select
    ActiveCell.FormulaR1C1 = "PROJECT ADDRESS LINE 1"
    Range("AD1").Select
    ActiveCell.FormulaR1C1 = "PROJECT ADDRESS LINE 2"
    Range("AE1").Select
    ActiveCell.FormulaR1C1 = "PROJECT CITY"
    Range("AF1").Select
    ActiveCell.FormulaR1C1 = "PROJECT STATE CODE"
    Range("AG1").Select
    ActiveCell.FormulaR1C1 = "PROJECT COUNTY"
    Range("AH1").Select
    ActiveCell.FormulaR1C1 = "PROJECT COUNTRY CODE"
    Range("AI1").Select
    ActiveCell.FormulaR1C1 = "PROJECT ZIP"
    Range("AJ1").Select
    ActiveCell.FormulaR1C1 = "DATE ADDED"
 
    Columns("AK:AK").Select
    Selection.ClearContents
 
'Sub deleteDuplicate(WSName As String)
        'cRow = 2
        'Do While IsEmpty(Worksheets("Pivot Data").Cells(cRow, 1)) = False 'change sheet name
            'cRow2 = cRow + 1
            'Do While IsEmpty(Worksheets("Pivot Data").Cells(cRow2, 1)) = False
                'foundDuplicate = True
                'For cCol = 1 To 35
                    'If Worksheets("Pivot Data").Cells(cRow, cCol).Value  Worksheets("Pivot Data").Cells(cRow2, cCol).Value
Then
                        'foundDuplicate = False
                        'Exit For
                    'End If
                'Next
                'If foundDuplicate = True Then
                    'Worksheets("Pivot Data").Rows(cRow2).Delete xlShiftUp
                    'Worksheets("Pivot Data").Rows(cRow2).Delete xlShiftUp 'guess
                'Else
                    'cRow2 = cRow2 + 1
                'End If
            'Loop
            'cRow = cRow + 1
        'Loop
'End of old delete duplicates
 
    'Sort all data by the date added with the newest first
        Sheets("Pivot Data").Activate
        Range("A1:AJ65536").Sort Key1:=Range("AJ2"), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
    'refresh pivote charts
        Sheets("Region 1.1").Select
        Range("A3").Select
        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        Application.CutCopyMode = False
        ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
'Date Stamp for pivot table data highlighting
        Sheets("Region 1.1").Select
        Range("A4").Select
        Range("A4").FormulaR1C1 = Date
    'Add Border
            Range("A9").Select
            Selection.CurrentRegion.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
        'Left justify chart and center title bar
        With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("9:9").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'Date Stamp for pivot table data highlighting
        Sheets("1.2").Select
        Range("A4").Select
        Range("A4").FormulaR1C1 = Date
    'Add border
            Range("A9").Select
            Selection.CurrentRegion.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
    'Left Justify chart and center title row
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("9:9").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'Date Stamp for pivot table data highlighting
        Sheets("1.3").Select
        Range("A4").Select
        Range("A4").FormulaR1C1 = Date
    'Add border
            Range("A9").Select
            Selection.CurrentRegion.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
            'Left Justify chart and center title row
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("9:9").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'Date Stamp for pivot table data highlighting
        Sheets("Region 2.1").Select
        Range("A4").Select
        Range("A4").FormulaR1C1 = Date
    'Add border
            Range("A9").Select
            Selection.CurrentRegion.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
            'Left Justify chart and center title row
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("9:9").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'Date Stamp for pivot table data highlighting
        Sheets("2.2").Select
        Range("A4").Select
        Range("A4").FormulaR1C1 = Date
    'Add border
            Range("A9").Select
            Selection.CurrentRegion.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
            'Left Justify chart and center title row
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("9:9").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'Date Stamp for pivot table data highlighting
        Sheets("2.3").Select
        Range("A4").Select
        Range("A4").FormulaR1C1 = Date
    'Add border
            Range("A9").Select
            Selection.CurrentRegion.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
            'Left Justify chart and center title row
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("9:9").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'Date Stamp for pivot table data highlighting
        Sheets("Region 3.1").Select
        Range("A4").Select
        Range("A4").FormulaR1C1 = Date
    'Add border
            Range("A9").Select
            Selection.CurrentRegion.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
            'Left Justify chart and center title row
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("9:9").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'Date Stamp for pivot table data highlighting
        Sheets("3.2").Select
        Range("A4").Select
        Range("A4").FormulaR1C1 = Date
    'Add border
            Range("A9").Select
            Selection.CurrentRegion.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
            'Left Justify chart and center title row
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("9:9").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
'Date Stamp for pivot table data highlighting
        Sheets("3.3").Select
        Range("A4").Select
        Range("A4").FormulaR1C1 = Date
    'Add border
            Range("A9").Select
            Selection.CurrentRegion.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
            'Left Justify chart and center title row
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("9:9").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
    'Hide Sheet and save worksheet
    Sheets("Data Sheet").Activate
    'ActiveSheet.Visible = False
    Sheets("Pivot Data").Activate
    'ActiveWorksheet.Protect Structure:=True, Windows:=False
    ActiveWorkbook.Save
 
End Sub
Here is the code. If this is not readible enough I can attach a file, but I will have to work on an example that I am able to post. Please let me know, any insight would be greatly appreciated.

Thanks in advance for the help,

Dawson

I am setting up a Excel Linked workbook to Access and I begin by exporting a query out of Access and manipulating the data then sending this new data to a spreadsheet linked to an Access Table. This will be done weekly. I created the below VBA using macro recording and want to know if this routine will work if the number of rows in the next incoming sheet differs from the one I created the macro with? I am using Excel 2003 on this one. If not what should I use to make the range dynamic? Thanks for any help you may give me.

Sub Bens2SortDatabase()
'
' SortBensDatabase Macro
' Macro recorded 11/26/2007 by Milo E Bisconer
'

'
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Range("A1:T28393").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(5, 6, 7, 8, _
9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20), Replace:=True, PageBreaks:=False, _
SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 9)), TrailingMinusNumbers:=True

End Sub

Here is the macro I'm working with.
I have others that are very similar in that they all retrieve a page (table) and paste it into its own sheet in the same workbook, after which a series of minor formatting operations are performed (columns deleted, rows deleted, and columns resized).

Sub RealTimeStats()
'
' RealTimeStats Macro
' Macro recorded 10/14/2010 by Scott
'

'
    With ActiveSheet.QueryTables.Add(Connection:= _
       
"URL;http://www.nhl.com/ice/teamstats.htm?fetchKey=20112ALLAAAAll&sort=team.displayAbbrev&viewName=realTimeStats"
_
        , Destination:=Range("A1"))
        .Name = _
        "teamstats.htm?fetchKey=20112ALLAAAAll&sort=team.displayAbbrev&viewName=realTimeStats_1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .Refresh BackgroundQuery:=False
    End With
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:8").Select
    Range("A8").Activate
    Selection.Delete Shift:=xlUp
    Columns("A:A").ColumnWidth = 13.29
    Range("A1").Select
End Sub

My question applies mostly to the bottom part of this code..

How can i re-arrange all this stuff so that it is on one line?
That is, how can I make the formatting part of this macro more VBA efficient?

Someone told me a while back that it was possible to group different commands and operations onto one line, saving alot of space, thereby making the code more efficient.

As a heads up, i know next to nothing about VBA specifically, though i have taken some C++ a while back (many years now) so i'm not a total alien when it comes to programming.

For excel, all my macros are 'recorded', so they end up being quite long and large, due to my inability to trim them myself and make them more efficient.

Hi,

I am fairly new in VBA for Excel programming and i get along normally by just recording macros every now and then. I have a new template working on that requires repetitive action to be done with the file and i know that there is a way to shorten this using arrays and/or loops. I have pasted below the code that i have used for the project as well as the sub that works hand-in-hand with the main code.

What the code basically does is to remove certain rows and columns from a spreadsheet. If you will notice i have repetitive codes that i need to get rid of.

Main

Sub
PrepareFormat ()

    Columns("Z:Z").Select
    Selection.Delete Shift:=xlToLeft

    Columns("X:X").Select
    Selection.Delete Shift:=xlToLeft

    Columns("V:V").Select
    Selection.Delete Shift:=xlToLeft

    Columns("T:T").Select
    Selection.Delete Shift:=xlToLeft

    Columns("S:S").Select
    Selection.Delete Shift:=xlToLeft

    Columns("R:R").Select
    Selection.Delete Shift:=xlToLeft

    Columns("Q:Q").Select
    Selection.Delete Shift:=xlToLeft

    Columns("N:N").Select
    Selection.Delete Shift:=xlToLeft

    Columns("M:M").Select
    Selection.Delete Shift:=xlToLeft

    Columns("J:J").Select
    Selection.Delete Shift:=xlToLeft

    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft

    Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft

    Columns("E:E").Select
    Selection.Delete Shift:=xlToLeft

    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft

    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft


    Cells.Select
    Selection.ColumnWidth = 20
    Selection.RowHeight = 12.75

    Call DeleteBlankRows



End Sub
Sub

Sub DeleteBlankRows()

Dim i As Long

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False

    For i = Selection.Rows.Count To 1 Step -1

        If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
            Selection.Rows(i).EntireRow.Delete
            
        End If

        If WorksheetFunction.CountA(Selection.Rows(i)) = 1 Then
            Selection.Rows(i).EntireRow.Delete
            
        End If

        If WorksheetFunction.CountA(Selection.Rows(i)) = 2 Then
            Selection.Rows(i).EntireRow.Delete

        End If

	If WorksheetFunction.CountA(Selection.Rows(i)) = 9 Then
            Selection.Rows(i).EntireRow.Delete

        End If

    Next i

        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True

    End With

End Sub
As you can see, this is pretty basic. Would appreciate any help you guys can send my way.

Thanks.

Hello, could some one please help me modify my code so that I can select a MS Word 2003 Table from my Excel 2003 macro? I keep getting Error 438 as per attached file for the line of code:

Any help is greatly appreciated.

Kind regards,

Chris

Sub Data_to_Text()
'
' Data to Text Macro
' Macro recorded 9/02/2010
'

'
    Dim myRange As Range
    Dim LastRow As Long
    Dim docWord As Object
    
    

    Application.ScreenUpdating = False
    
    Set myRange = Selection
    
    Sheets("Data").Select
    
    For Each cell In myRange
        Range(cell.Address).Value = cell.Value
    Next cell
    
    Selection.Copy
    
    Sheets("Data to Text").Select
    
    ActiveSheet.Paste
    
    Columns("A:A").Select
    
    Application.CutCopyMode = False
    
    Selection.Insert Shift:=xlToRight
    
    Rows("1:10").Select
    Selection.RowHeight = 22.5
    
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=R[-1]C+1"
    
    LastRow = Cells(Rows.Count, "B").End(xlUp).Row

    Range("A2").AutoFill Destination:=Range("A2:A" & LastRow)
    
    Range("G:G,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S").Select
    Range("S1").Activate
    
    Selection.Delete Shift:=xlToLeft
    
    ActiveSheet.Range("A1:J1", ActiveSheet.Range("A65536").End(xlUp)).Select
    
    Selection.Copy

    Set docWord = CreateObject("Word.Application")
    docWord.Visible = True
    
    docWord.Documents.Add
    docWord.Selection.Paste
     
    Application.CutCopyMode = False
     
    Set docWord = Nothing
    
    Selection.Tables(1).Select
      
    Selection.Rows.ConvertToText Separator:=wdSeparateByDefaultListSeparator, _
        NestedTables:=True
        
    Application.ScreenUpdating = True
        
End Sub


Hi, i have some VBA code in an Access DB that opens an Excel spreadsheet at a specific workbook, and then performs some formatting on the sheet, before saving the changes and closing the workbook.

The first time i run the sub it works perfectly. If i then try and run it again i get a run-time error 91 message (Object variable or With Block variable not set). This happens every subsequent time i try and run the code until i manually reset.

The error message is always at the same point.

Here's the code:

I've put ***ERROR MESSAGE HERE*** at the point in the code the error seems to be occuring

Public Sub testExcel()

Dim objExc As Object
Dim lngXtra As Variant
Dim strExcelFile As String
Dim strWorksheet As String


strExcelFile = "filepath here"
strWorksheet = "St_James"

Set objExc = CreateObject("Excel.Application")

lngXtra = 4

With objExc
        .Visible = True
        .Workbooks.Open (strExcelFile)
        .Worksheets(strWorksheet).Select       
        
Call .Range("A1:A" & lngXtra).EntireRow.Insert
        
        .Cells.Select
             
             With Selection.Interior              **** ERROR MESSAGE HERE****
                           .PatternColorIndex = 2
             End With
            
             With Selection.Font
                           .Name = "Calibri"
             End With
             
        .Range("A5:H5").Select
            
             With Selection.Font
                           .Bold = "True"
             End With
             
             With Selection.Borders
                           .Weight = xlThin
             End With
            
             With Selection.Interior
                           .ColorIndex = 48
             End With
    
             With Selection
                           .HorizontalAlignment = xlCenter
             End With   
    
    .Columns("A:H").EntireColumn.AutoFit
    .Range("I:K").Select
            Selection.Delete Shift:=xlToLeft
    
    ActiveWorkbook.Close SaveChanges:=True
    
    objExc.Quit   
    
End With

End Sub

Thanks in advance for any help

Hi,

I am trying to do an automated system, but have now run into some serious problems with Excel.

I have done a master excel application that has the following VB in it.

PHP Code: 
Private Sub Workbook_Open()


    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:phpdevwwwproduploadconvertacmehardware1.txt", Destination:=Range( _
        "A1"))
        .Name = "shareasale"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = xlWindows
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = "|"
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .Refresh BackgroundQuery:=False
    End With
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:C").Select
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    ActiveWindow.SmallScroll ToRight:=3
    Columns("E:E").Select
    ActiveWindow.SmallScroll ToRight:=1
    Selection.Delete Shift:=xlToLeft
    Columns("F:F").Select
    Selection.Delete Shift:=xlToLeft
    Columns("H:H").Select
    Selection.Cut
    ActiveWindow.SmallScroll ToRight:=-2
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight
    ActiveWindow.SmallScroll ToRight:=1
    Columns("I:S").Select
    Selection.Delete Shift:=xlToLeft
    ActiveWindow.SmallScroll ToRight:=-1
    Range("I2").Select
    ActiveCell.FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
    Range("I2").Select
    Selection.AutoFill Destination:=Range("I2:I47684"), Type:=xlFillDefault
    Range("I2:I47684").Select
    ActiveWindow.ScrollRow = 1
    ActiveWindow.SmallScroll ToRight:=1
    Columns("I:I").Select
    Selection.Copy
    Columns("M:M").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Columns("G:L").Select
    Range("L1").Activate
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    ActiveWindow.SmallScroll ToRight:=-1
    Columns("G:G").Select
    Selection.Cut
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight
    ActiveWindow.SmallScroll ToRight:=-4
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    ChDir "C:phpdevwwwproduploadupload"
    ActiveWorkbook.SaveAs Filename:= _
        "C:phpdevwwwproduploaduploadacmehardware1.txt", FileFormat:=xlText, _
        CreateBackup:=False
    Application.DisplayAlerts = False
    Application.Quit
    ThisWorkbook.Close
    Application.DisplayAlerts = True
    
End Sub 
With this master excel document I am using php code to copy it and paste it in its own unique folder. While this process happens the excel file is also renamed. But as you can see within the above VB code, I have the following, which I need to also automatically change.

This is shown as follows:

"TEXT;C:phpdevwwwproduploadconvertacmehardware1.txt",

and

"C:phpdevwwwproduploaduploadacmehardware1.txt",

The url paths are correct, but the .txt file names needs to be changed to the same name as the excel file apart from they will have .txt at the end instead of xls.

Is there any way of doing this using php includes or a mysql database. Or even could I directly access each VBA file so that I can automatically edit these files and then change their file extensions to the proper VBA extension once I have edited them.

Is there any way.

Even if I could use a php script to fine the "acmehardware1.txt" part of the VBA code and then chage it with the proper name using a php script.

There just have to be a way as I have run out of options and I am now starting to think that my plans are not going to go to plan.

Please Help!!

Thanks!

First I want to say Hello all. I am just now really getting into heavly using excel and VBA's. I am taking a class on excel this semester and classes on VBA and SQL programming next semester. I am excited to learn a new and valuable skillset. I am also looking forward to contribuiting to the forum.

Ok so here is my question. I have a workbook that changes month to month on the number of tabs it has. The reason for this is it is used to import Journal Entries into an accounting software. It is much faster doing it this way rather than have someone else manually enter them. All of the Workbooks contain the same number of columns. However, the number of rows varry. The workbooks are set up like this:

A B C D I
Account number Debits Credits Description Reference

First I want to name all worksheets in the workbook based on the value in cell I1. Second step the accounting software we use sees Credits as Negative numbers so what I need to happen first is for the macro to look in column C and when it finds a cell with a number in it, copy the Account number in A and move it to the next open cell in Column A and then in the same row in column B copy the number from C and paste as a Negitive value in B and so on. Then I want the macro to delete the entire column D and shift all other columns to the left so that D now becomes C. Also deleting columns H and I. I would also like the macro to save each worksheet as a new workbook in G:UsersAndy2011GJ's, Pr's, GJTR's, GJTPr's

I have created the following macros but only the rename worksheets macro does all worksheets at once. I can not figure out the part where it will find a value in C and copy the account number and move it to the next open cell in A and copy and paste the value in C as a neg. In case this doesnt make sense Ill give an illustration.

A B C D
1 60 0 Example
5 55 10 Example
3 40 0 Example
9 0 20 Example

I need it to look like this:
1 60 0 Example
5 55 10 Example
3 40 0 Example
9 0 20 Example
5 -10 0 Example
9 -20 0 Example

and so on there may be only 2 rows but there could be 100 it varies.

I have the following macros already. For explanation purposes I am going to number each macro.

Macro 1.

Change name of worksheets in workbook
Sub Worksheet_Name_GJ_Import_Uses_Cell_I1()
Dim ws As Worksheet
For Each ws In Worksheets
On Error Resume Next
ws.Name = ws.Range("I1").Value
If Err.Number <> 0 Then
Err.Clear
Exit Sub
End If
Next ws
End Sub

Macro 2.

And
used to ensure all cells in B are a value and to delete C and move D to C then Delete H and I.
Sub GJ_CLEANUP_PRIOR_TO_IMPORT()
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("H:I").Select
Selection.Delete Shift:=xlToLeft
Dim LastRow As Long, n As Long

LastRow = Range("B65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If Cells(n, 2).Value = 0 Then Cells(n, 2).EntireRow.Delete
Next n
End Sub

Macro 3.

And then I use this to delete all rows that have a zero in B.
Sub Delete_ALL_ROWS_EQUAL_TO_0_Column_B()
Dim LastRow As Long, n As Long

LastRow = Range("B65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If Cells(n, 2).Value = 0 Then Cells(n, 2).EntireRow.Delete
Next n

End Sub

I am asking for help putting all of these together into 1 macro and adding the things from above added in. The Copy and pasting based on C would go inbetween Macro 1 and 2. And the make each worksheet a new workbook and saved in G:UsersAndy2011GJ's, Pr's, GJTR's, GJTPr's Would be last. I have played around with trying to build a macro for this but I have not been successful. I hope What I am asking is clear. Thanks a ton and hopefully someday soon I will be able to be one of the ones answering the questions instead of asking them. Andy

Hello,

Excel 2000 and Windows XP

I have some simple code which is supposed to go through 20 worksheets and
delete Column C in each sheet.. The code is below. Each sheet is filled
with content from cols A-O but instead of deleting col c in each sheet the
code below deletes whats in cols a-n in all sheets and puts what is in O in
col A.

Confusing I know but irritating. Can anyone tell me why the code below does
not just delete Col C in each sheet?

Thanks,

td.

Sub testdel()
'
' testdel Macro
' Macro recorded 06/04/2005 by blah blah
'
Sheets("RFC00020").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00035").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00040").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00050").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00060").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00100").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00101").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00102").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00103").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00104").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00199").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00200").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00201").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00202").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00203").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00204").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00299").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00300").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00303").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00304").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00403").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Sheets("RFC00404").Select
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

End Sub

Hi,

I am working on a project that requires me to develop a quite large, but not overly complicated spreadsheet. I have been asked to make the user interface as good as possible despite being a novice when it comes to the use of Macros and VBA in Excel.

Essentially my problems is as follows; When the user presses a button I want one row of the sheet he/she is in to be deleted, subsequently a number of worksheets, rows and columns are deleted so that the output sheet does not include errors. Is it a good way to write such a code that ensures that only this line is deleted and the curresponding button dissappears so that the various buttons always refers to the same row despite rows above being deleted.

Any help would be greatly appreciated

I tried to make this code using the recording function in excel and the output was as follows:

' DeleteP1 Macro
'
Rows("5:5").Select
Selection.Delete Shift:=xlUp
Sheets("Scrap").Select
Columns("B:B").Select
ActiveWindow.SmallScroll Down:=41
Selection.Delete Shift:=xlToLeft
Sheets("Defect type #1").Select
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Defect type #2").Select
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Defect type #3").Select
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Defect type #4").Select
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Defect type #5").Select
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Sheets("Defect type #6").Select
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets("Calc").Select
Columns("B:B").Select
Range("B4").Activate
Selection.Delete Shift:=xlToLeft
Range("J8:P8").Select
Selection.ClearContents
Sheets("Report").Select
End Sub

Hello everyone, I am new to VBA and macros in Excel.

I have created a macro via a recording. At one point during the recording I select the top-most row and delete it. However, when I run the macro I see that that row is not deleted... Here is the relevant chunk of code:

...
 ActiveWindow.ScrollRow = 7
    ActiveWindow.ScrollRow = 3
    ActiveWindow.ScrollRow = 1
    Range("N2").Select
    ActiveSheet.Paste
    Columns("M:M").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    Range("M1").Select
    Windows("AK_macro_format_test.xlsm").Activate
    ActiveWindow.ScrollRow = 1123
    ActiveWindow.ScrollRow = 1116
    ActiveWindow.ScrollRow = 1101
...
There are no errors thrown, and everything else works great. Thank you in advance!

Hi All,

I've written a macro in excel 2003 which ran very smoothly (+- 1 second). I've installed excel 2007 and converted the file to .xlsm. The macro now takes +- 5 minutes to run and sometimes causes excel to crash.

I was hoping someone could guide me in the right direction and suggest improved code as i'm not all that pro at VBA yet.

Sub SheetToCSV()

' Macro recorded 08/04/2011 by Jeremy

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual

    Application.DisplayAlerts = False

 

' Create duplicate tab and edit format to required spec (delete unwanted columns, format general, etc.)

 

    Cells.Select

    Selection.Copy

    Sheets.Add.Name = "US_COST_AND_REVENUE_ADJUSTMENT_"

    ActiveSheet.Paste

    Range("A:A,D:E").Select

    Range("D1").Activate

    Application.CutCopyMode = False

    Selection.Delete Shift:=xlToLeft

    Range("H2:BO250").Select

    Selection.NumberFormat = "General"

 

 ' Delete content after last row of data

 

    lrow = Cells(1, 1).End(xlDown).Row

    Range(Cells(lrow + 1, 1), Cells(Rows.Count, 1).End(xlToRight)).Delete Shift:=xlUp

 

' Round cells with values to two decimal places and replace all cells containing zero values with blank

    Dim cell As Range

 

    For Each cell In Range("H2:BO250")

        cell.Value = WorksheetFunction.Round(cell.Value, 2)

    Next cell

 

    Range("H:BO").Replace What:="0", Replacement:="", LookAt:=xlWhole

 

' Copy modified tab and create csv file with a date and time stamp. Delete modified tab from spreadsheet.

    Worksheets("US_COST_AND_REVENUE_ADJUSTMENT_").Copy

 

        ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & "US_COST_AND_REVENUE_ADJUSTMENT_" & _

            Format(Now(), "ddmmyy_hhmm") & ".csv", FileFormat:=xlCSV, CreateBackup:=False

        ActiveWorkbook.Close

 

   Worksheets("US_COST_AND_REVENUE_ADJUSTMENT_").Delete

 

' Turn on all supressed application settings and display message box when process completed

  Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

    Application.ScreenUpdating = True

    Range("A1").Select

    MsgBox "Process complete.  You're amazing..."

    MsgBox "But you smell"

 

End Sub


I am trying to convert this macro Recoded code Completely into VBA mainly to reduce the length of the code and also primarily for the creating a dynamic range . But I keep getting an error .My main error is probably because I am mixing them both and not sure where to correct the code.
most of these VBA code have been pulled from the net
I need to know what is going wrong here.


	VB:
	
 
 ' Downloaded from www.contextures.com
Sub CreateNames() 
     ' written by Roger Govier, Technology4U
     
     
    Dim wb As Workbook, ws As Worksheet 
    Dim lrow As Long, lcol As Long, i As Long 
    Dim myName As String, Start As String 
     
     
     ' set the row number where headings are held as a constant
     ' change this to the row number required if not row 1
    Const Rowno = 1 
     
     
     ' set the Offset as the number of rows below Rowno, where the
     ' data begins
    Const ROffset = 1 
     
     
     ' set the starting column for the data, in this case 1
     ' change if the data does not start in column A
    Const Colno = 1 
     
     ' Set an Offset from the starting column, for the column number that
     ' will always have data entered, and will therefore be used in calculating lrow
     
    Const COffset = 0 ' in this case, the first column will always contain data.
     
     
    On Error Goto CreateNames_Error 
     
     
    Set wb = ActiveWorkbook 
    Set ws = ActiveSheet 
     
     
     ' count the number of columns used in the row designated to
     ' have the header names
     
    lcol = Cells(Rowno, Columns.Count).End(xlToLeft).Column 
    lrow = ws.Cells(Rows.Count, Colno).End(xlUp).Row 
    Start = Cells(Rowno, Colno).Address 
     
    wb.Names.Add Name:="lcol", RefersTo:="=COUNTA($" & Rowno & ":$" & Rowno & ")" 
    wb.Names.Add Name:="lrow", RefersToR1C1:="=COUNTA(C" & Colno + COffset & ")" 
    wb.Names.Add Name:="myData", RefersTo:= _ 
    "=" & Start & ":INDEX($1:$65536," & "lrow," & "Lcol)" 
     
     
    For i = Colno To lcol 
         ' if a column header contains spaces, replace the space with an underscore
         ' spaces are not allowed in range names.
        myName = Replace(Cells(Rowno, i).Value, " ", "_") 
        If myName = "" Then 
             ' if column header is blank, warn the user and stop the macro at that point
             ' names will only be created for those cells with text in them.
            MsgBox "Missing Name in column " & i & vbCrLf _ 
            & "Please Enter a Name and run macro again" 
            Exit Sub 
        End If 
        wb.Names.Add Name:=myName, RefersToR1C1:= _ 
        "=R" & Rowno + ROffset & "C" & i & ":INDEX(C" & i & ",lrow)" 
nexti: 
    Next i 
     
     
    On Error Goto 0 
    MsgBox "All dynamic Named ranges have been created" 
    Exit Sub 
     
     
    Exit Sub 
     
     
CreateNames_Error: 
     
     
    MsgBox "Error " & Err.Number & " (" & Err.Description & _ 
    ") in procedure CreateNames of Module Technology4U" 
     
     
     '
    Set myData = Range 
    Application.ScreenUpdating = False 
    myData.Select 
     
    .Columns("E:J").Select 
    .Selection.DELETE Shift:=xlToLeft 
    .Range("F7").Select 
    Columns("F:F").EntireColumn.AutoFit 
    Columns("A:A").ColumnWidth = 13.43 
    Columns("B:B").ColumnWidth = 13.29 
    Columns("A:A").ColumnWidth = 22.86 
    Columns("A:B").Select 
    Selection.DELETE Shift:=xlToLeft 
    Columns("C:C").Select 
    Selection.Cut 
    Columns("A:A").Select 
    Selection.Insert Shift:=xlToRight 
    Columns("C:C").Select 
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 
    Range("C2").Select 
    ActiveCell.FormulaR1C1 = "=RC[-2]&""-""&RC[-1]" 
    Range("C2").Select 
    Selection.AutoFill Destination:=Range("C2:C304") 
    Range("C2:C304").Select 
    Range("C2").Select 
    Columns("C:C").ColumnWidth = 15.86 
    Range("C1").Select 
    ActiveCell.FormulaR1C1 = "StoreInvoice" 
    Range("C2").Select 
    ActiveWindow.ScrollRow = 2 
    ActiveWindow.ScrollRow = 7 
    ActiveWindow.ScrollRow = 11 
    ActiveWindow.ScrollRow = 18 
    ActiveWindow.ScrollRow = 24 
    ActiveWindow.ScrollRow = 39 
    ActiveWindow.ScrollRow = 59 
    ActiveWindow.ScrollRow = 93 
    ActiveWindow.ScrollRow = 121 
    ActiveWindow.ScrollRow = 155 
    ActiveWindow.ScrollRow = 187 
    ActiveWindow.ScrollRow = 207 
    ActiveWindow.ScrollRow = 214 
    ActiveWindow.ScrollRow = 223 
    ActiveWindow.ScrollRow = 228 
    ActiveWindow.ScrollRow = 236 
    ActiveWindow.ScrollRow = 240 
    ActiveWindow.ScrollRow = 243 
    ActiveWindow.ScrollRow = 246 
    ActiveWindow.ScrollRow = 250 
    ActiveWindow.ScrollRow = 251 
    ActiveWindow.ScrollRow = 253 
    ActiveWindow.ScrollRow = 255 
    ActiveWindow.ScrollRow = 256 
    ActiveWindow.ScrollRow = 257 
    ActiveWindow.ScrollRow = 260 
    ActiveWindow.ScrollRow = 261 
    ActiveWindow.ScrollRow = 262 
    ActiveWindow.ScrollRow = 264 
    ActiveWindow.ScrollRow = 265 
    ActiveWindow.ScrollRow = 266 
    ActiveWindow.ScrollRow = 268 
    ActiveWindow.ScrollRow = 273 
    ActiveWindow.ScrollRow = 277 
    ActiveWindow.ScrollRow = 281 
    ActiveWindow.ScrollRow = 283 
    ActiveWindow.ScrollRow = 274 
    ActiveWindow.ScrollRow = 265 
    ActiveWindow.ScrollRow = 257 
    ActiveWindow.ScrollRow = 253 
    ActiveWindow.ScrollRow = 244 
    ActiveWindow.ScrollRow = 238 
    ActiveWindow.ScrollRow = 227 
    ActiveWindow.ScrollRow = 219 
    ActiveWindow.ScrollRow = 211 
    ActiveWindow.ScrollRow = 206 
    ActiveWindow.ScrollRow = 200 
    ActiveWindow.ScrollRow = 197 
    ActiveWindow.ScrollRow = 191 
    ActiveWindow.ScrollRow = 188 
    ActiveWindow.ScrollRow = 184 
    ActiveWindow.ScrollRow = 177 
    ActiveWindow.ScrollRow = 172 
    ActiveWindow.ScrollRow = 167 
    ActiveWindow.ScrollRow = 162 
    ActiveWindow.ScrollRow = 155 
    ActiveWindow.ScrollRow = 151 
    ActiveWindow.ScrollRow = 146 
    ActiveWindow.ScrollRow = 141 
    ActiveWindow.ScrollRow = 135 
    ActiveWindow.ScrollRow = 131 
    ActiveWindow.ScrollRow = 124 
    ActiveWindow.ScrollRow = 120 
    ActiveWindow.ScrollRow = 114 
    ActiveWindow.ScrollRow = 111 
    ActiveWindow.ScrollRow = 106 
    ActiveWindow.ScrollRow = 103 
    ActiveWindow.ScrollRow = 99 
    ActiveWindow.ScrollRow = 97 
    ActiveWindow.ScrollRow = 93 
    ActiveWindow.ScrollRow = 90 
    ActiveWindow.ScrollRow = 88 
    ActiveWindow.ScrollRow = 85 
    ActiveWindow.ScrollRow = 83 
    ActiveWindow.ScrollRow = 82 
    ActiveWindow.ScrollRow = 80 
    ActiveWindow.ScrollRow = 78 
    ActiveWindow.ScrollRow = 77 
    ActiveWindow.ScrollRow = 75 
    ActiveWindow.ScrollRow = 73 
    ActiveWindow.ScrollRow = 70 
    ActiveWindow.ScrollRow = 68 
    ActiveWindow.ScrollRow = 63 
    ActiveWindow.ScrollRow = 60 
    ActiveWindow.ScrollRow = 56 
    ActiveWindow.ScrollRow = 53 
    ActiveWindow.ScrollRow = 50 
    ActiveWindow.ScrollRow = 46 
    ActiveWindow.ScrollRow = 44 
    ActiveWindow.ScrollRow = 40 
    ActiveWindow.ScrollRow = 39 
    ActiveWindow.ScrollRow = 36 
    ActiveWindow.ScrollRow = 33 
    ActiveWindow.ScrollRow = 29 
    ActiveWindow.ScrollRow = 27 
    ActiveWindow.ScrollRow = 24 
    ActiveWindow.ScrollRow = 22 
    ActiveWindow.ScrollRow = 21 
    ActiveWindow.ScrollRow = 19 
    ActiveWindow.ScrollRow = 17 
    ActiveWindow.ScrollRow = 15 
    ActiveWindow.ScrollRow = 13 
    ActiveWindow.ScrollRow = 12 
    ActiveWindow.ScrollRow = 10 
    ActiveWindow.ScrollRow = 8 
    ActiveWindow.ScrollRow = 7 
    ActiveWindow.ScrollRow = 5 
    ActiveWindow.ScrollRow = 3 
    ActiveWindow.ScrollRow = 2 
    ActiveWindow.ScrollRow = 1 
    Columns("L:L").Select 
    Selection.DELETE Shift:=xlToLeft 
    Columns("K:K").ColumnWidth = 16.71 
    Range("N7").Select 
    Application.ScreenUpdating = False 
End Sub 
Sub Del_rows_with_zero_in_column_of_activecell() 
     'Charles Chickering, programming, 2007-02-09
    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 
    Const StartRow As Long = 1 'Row to Start looking at
    Dim StopRow As Long 
    Dim Col As Long 
    Col = ActiveCell.Column 
    StopRow = Cells(Rows.Count, Col).End(xlUp).Row 
    Dim cnt As Long 
    For cnt = StopRow To StartRow Step -1 
        If Not IsEmpty(Cells(cnt, Col)) Then 
            If IsNumeric(Cells(cnt, Col)) Then 
                If Cells(cnt, Col) = "" Then Rows(cnt).DELETE 
            End If 
        End If 
    Next cnt 
    Application.Calculation = xlCalculationAutomatic 
    Application.ScreenUpdating = True 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Can anyone help. I have put together the following code and it works fine on my PC. However, we are a mainly Mac based company and I nead it to work with a Mac. I am using the Actual ODBC Driver for Mac to give me a ODBC connection.

I can do the query in excel but setting it up as a macro just will not work.

Any ideas?


	VB:
	
 Sales_Query() 
     
    Columns("C:D").Select 
    Selection.Delete Shift:=xlToLeft 
    Range("B2").Select 
     
    Dim area As Variant 
     
     
    area = Range("B2") 
     
    With ActiveSheet.QueryTables.Add(Connection:=Array("ODBC;DSN=my_database;Description=My
Databse;DATABASE=mydatabse;Trusted_Connection=YES"), Destination:=Range("c5")) 
        .CommandText = Array("SELECT nareaid,cname FROM area WHERE nareaid=" & area & " ORDER BY nareaid") 
        .Name = "Query from Database" 
        .FieldNames = True 
        .RowNumbers = False 
        .FillAdjacentFormulas = False 
        .PreserveFormatting = True 
        .RefreshOnFileOpen = False 
        .BackgroundQuery = True 
        .RefreshStyle = xlInsertDeleteCells 
        .SavePassword = True 
        .SaveData = True 
        .AdjustColumnWidth = True 
        .RefreshPeriod = 0 
        .PreserveColumnInfo = True 
        .Refresh BackgroundQuery:=False 
    End With 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I have a spreadsheet that has data in columns A through AE. I have built a VBA that deletes all columns except 2 (columns C & AF), and brings them over to columns A & B. Column C contains a 10 digit number and column AF contains text similiar to "ASSIGNED ON 10 CALLS BOLDI". My VBA deletes all unneeded columns, but I am having trouble getting it to do 2 additional functions. I want it to delete the verbiage of "Assigned ON" in the cells under column AF, and delete the last number of the account number under column C, so that the account number is only 9 digits long.
Here is my VBA:

	VB:
	
 FixList() 
    Application.ScreenUpdating = False 
    Dim x As Long, tr As Long 
     ' Delete Columns
    Range("A:B,D:AC,AE:AE").Select 
    Range("AE1").Activate 
    Application.CutCopyMode = False 
    Selection.Delete Shift:=xlToLeft 
     'Combine symbols for same account numbers
    For x = tr To 2 Step -1 
        If Range("A" & x) = Range("A" & (x - 1)) Then 
            Range("B" & (x - 1)).Value = Range("B" & (x - 1)).Value & ", " & Range("B" & (x)).Value 
            Rows(x).Delete 
        End If 
    Next x 
    Application.ScreenUpdating = True 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Any help would be greatly appreciated.


No luck finding an answer? You could always try Google.