Free Microsoft Excel 2013
Quick Reference
Free Microsoft 2013 Quick Reference Guide

Free Microsoft Excel 2013 Quick Reference

Autofit columns widths in vba Results

Hi,

I have put together the following Print Setup VBA code behind a command button, but I can't get it to work properly:

Sub Print_Report()
Application.ScreenUpdating = False
With Worksheets("Rates").PageSetup
.DisplayPageBreaks = False
.PrintTitleRows = "A9:LastColumn"
.LeftMargin = Application.InchesToPoints(0.3)
.RightMargin = Application.InchesToPoints(0.3)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.CenterHorizontally = True
.Orientation = xlPortrait
.FirstPageNumber = xlAutomatic
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Application.ScreenUpdating = True
Selection.PrintOut Copies:=1, Collate:=True
End Sub

I need to fix some of the code to incorporate the following rules:

I want the Macro to:
1: Include data in report from cells A5 to last column/last row
2. Print column titles on every page (Columns titles are now found on Row 9 starting from A9 to last column)
3. Autofit Columns to best Width
4. Scale Worksheet to fit all columns on One Page

First off I am new to the whoel VBA/Macro world and I am learning as I go so please be gentle... I have 3 seperate Macro functions that I would like to combine into one "click this button" and you're done process. Here is what I'm working with:

Step #1 combines data from 7 different pages into 1 page:
PHP Code: 
Sub ShelmanCopyRangeVersion2()

    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "CompareMacro" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("CompareMacro").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "RDBMergeSheet"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "CompareMacro"
    Range("A1:B1").Value = Array("Sevice Order", "Manufacturer")
    'Fill in the start row
    StartRow = 1

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Sheets(Array("SS Old Tags", "SS HP_Compaq Laptops", "SS Toshiba Laptops", "SS Gateway_Emach Laptops", "SS Sony_Misc Laptops", "SS Desktops", "SS PT", "SS PA"))
                    
                    'Find the last row with data on the DestSh
            Last = LastRow(DestSh)

            'Fill in the range that you want to copy
            Set CopyRng = sh.Range("A1:B500")

            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If

            'This example copies values/formats, if you only want to copy the
            'values or want to copy everything look at the example below this macro
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

                        
            Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function 
Step #2 sorts the information into numerical order while deleting blank rows (while you're here, what's a good way to delete blanks without 'guessing' how blank rows there will be?):

PHP Code: 
Sub SortRemoveBlanks2()

'
' SortRemoveBlanks2 Macro
' Macro recorded 6/2/2008 by Shelman
'

    Columns("A:B").Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Rows("2:2").Select
    ActiveWindow.SmallScroll Down:=24
    Rows("2:49").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
End Sub 
And lastly step #3 takes this now combined and sorted information and "copies and pastes" to a seperate sheet with conditional formating and formulas already on the sheet and ready to go:

PHP Code: 
Sub CopyCompareMacroToCompare()

'
' CopyCompareMacroToCompare Macro
' Macro recorded 6/2/2008 by Shelman
'

    Columns("A:B").Select
    Selection.Copy
    Sheets("Compare").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
End Sub 
How can I combine these so that they are one click and done? Any help is appreciated!

Thanks!

Among others, I'm having some trouble getting Jim Rech's code to
Autofit Row height in merged cells to work the way I want it to.

Is there a simple worksheet event code I could use to Autofit Row in
four cells, preferably upon recalculation?

Specifically, A:N are merges in four different rows, 23, 47, 68, and
70

The width of column Column Z is is the same as A:N combined
Z23 is =A23
Z47 is =A27
etc.
Autofit doesn't automatically work in Z23 because of the formula, in
fact, F2 Enter doesn't even work. I have to paste values or select the
cells and Alt O R A.

I should figure this out myself, getting VBA for morons this weekend,
but if someone would help with this one I'd appreciate it.

Application.Goto Reference:="Z23,Z47,Z68,Z70"
Selection.Rows.AutoFit

I'm trying to correct some odd formatting errors which occurred when converting an Excel 2003 document opened in Excel 2007. The workbook in question is a series of paragraphs word wrapped in one column with a set width of 45. Each row is (or rather was) AutoFit so the row height matched the paragraph length perfectly.

The issue I'm trying to correct are random spaces at the end of certain paragraphs of text. Each space appears to be a perfect carriage reuturn and appears in about 30 of the 300 rows. AutoFit does not work with code, double clicking or via Excels interface.

I wrote some code which could be the issue, but it fine with all the other paragraphs and some test ones I've created. I can manually grab and move the width but there are enough legacy documents to justify the creation of this add-in. I'm wondering if the issue is indeed my code or there is something else at play.

I've checked the issue cells for blank space before and after as well. I did notice the Category is set to general instead of text. When I try and convert, it changes everything to ########. If I deleted the contents, change the category and paste in just the values of the text desired, everything appears as ####### as well.

I've played with the vertical alignment, word wrap and other formatting variable. If I create a new workbook, set a column width manually to 45, and paste values only into the cell and select word wrap. It eliminates the space.

Does this mean I have to write a conversion sub to copy over the values and manually read formatting settings from old document and then implement in a new document? I mean... isn't that kind of what Microsoft File Format Converter was supposed to do!?!

Another idea I was exploring was a better way to whitewash the formatting of the cell, making it default in all respects like the cell in a new excel workbook. I'm not certain if range.clear will suffice and how to paste values with code.

Below are my subs.

Thanks in advance for all hep and suggestions.

Sub vAlignTop(control As IRibbonControl)
    Dim myRange As Range
    Set myRange = ActiveWindow.RangeSelection
    With myRange
        myRange.Cells.VerticalAlignment = xlVAlignTop
    End With
    myRange.Activate
End Sub

Sub vAlignBot(control As IRibbonControl)
    Dim myRange As Range
    Set myRange = ActiveWindow.RangeSelection
    With myRange
        myRange.Cells.VerticalAlignment = xlVAlignBottom
    End With
    myRange.Activate
End Sub

Sub vAlignCen(control As IRibbonControl)
    Dim myRange As Range
    Set myRange = ActiveWindow.RangeSelection
    With myRange
        myRange.Cells.VerticalAlignment = xlVAlignCenter
    End With
    myRange.Activate
End Sub

Sub hAlignRig(control As IRibbonControl)
    Dim myRange As Range
    Set myRange = ActiveWindow.RangeSelection
    With myRange
        myRange.Cells.HorizontalAlignment = xlHAlignRight
    End With
    myRange.Activate
End Sub

Sub hAlignLef(control As IRibbonControl)
    Dim myRange As Range
    Set myRange = ActiveWindow.RangeSelection
    With myRange
        myRange.Cells.HorizontalAlignment = xlHAlignLeft
    End With
    myRange.Activate
End Sub

Sub hAlignCen(control As IRibbonControl)
    Dim myRange As Range
    Set myRange = ActiveWindow.RangeSelection
    With myRange
        myRange.Cells.HorizontalAlignment = xlHAlignCenter
    End With
    myRange.Activate
End Sub

Sub wwTrue(control As IRibbonControl)
    Dim myRange As Range
    Set myRange = ActiveWindow.RangeSelection
    With myRange
        myRange.Cells.WrapText = True
    End With
    myRange.Activate
End Sub

Sub wwFalse(control As IRibbonControl)
    Dim myRange As Range
    Set myRange = ActiveWindow.RangeSelection
    With myRange
        myRange.Cells.WrapText = False
    End With
    myRange.Activate
End Sub

Sub afRow(control As IRibbonControl)
    Dim myRange As Range
    Set myRange = ActiveWindow.RangeSelection
    For Each Item In myRange
        If Item <> Null Then
            myRange.RowHeight = 1
            myRange.RowHeight.AutoFit = True
        End If
    Next
    myRange.Activate
End Sub

Sub afCol(control As IRibbonControl)
    Dim myRange As Range
    Set myRange = ActiveWindow.RangeSelection
    For Each cell In myRange
        If cell <> Null Then
            myRange.ColumnWidth = 1
            myRange.ColumnWidth.AutoFit = True
        End If
    Next
    myRange.Activate
End Sub


Hi all,

I'm looking to see if I can do a search on a pivot table for the word "Total" which is in row 4 and then adjust the column width for each cell it finds to 2.5

I've recorded the below which works if you use ctrl A to select all but when i run the macro it changes all the column widths to 2.5

Any thoughts ??

VBA:
Sub Autofit()

Cells.EntireColumn.Autofit
Rows("4:4").Select
Selection.Find(What:="total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Selection.ColumnWidth = 2.5
End Sub

Thanks in advance

VBA Noob

Hi All,

I have a vba code that copy the range from multiple worksheets. The Code does not run due to error highlighted below...

Please solve ill be very thankful to you....

Sub
CopyRangeFromMultiWorksheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim CopyRng As Range
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "Sheet1" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Sheet1").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "Sheet1"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Sheet1"

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then

            'Find the last row with data on the DestSh
            Last = lastRow(DestSh)

            'Fill in the range that you want to copy
            Set CopyRng = sh.Range("A1:G1")

            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If

            'This example copies values/formats, if you only want to copy the
            'values or want to copy everything look at the example below this macro
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

            'Optional: This will copy the sheet name in the H column
            DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
Thanks and Regards
Farrukh

Hi, I am in desperate need of someone with more VBA knowledge than me (not difficult). I have managed to get the following code (courtesy of Ron de Bruin) working on my workbooks but it isn't quite doing what it needs to and I don't have the skills to cobble from other sources

Sub MergewithAutoFilter()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() 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 rng As Range, SearchValue As String
Dim FilterField As Integer, RangeAddress As String
Dim ShName As Variant, RwCount As Long
'**************************************************************
'***Change these five lines of code before you run the macro***
'**************************************************************
' Change this to the pathfolder location of the files.
MyPath = "network pathfolder name)"
' Fill in the name of the sheet containing the data.
' Use ShName = "Sheet Name" to use a sheet name instead if its
' index. This example uses the index of the first sheet in
' every workbook.
ShName = "Pipeline"
' Fill in the filter range: A1 is the header of the first
' column and G is the last column in the range and will
' filter on all rows on the sheet.
' You can also use a fixed range such as A1:G2500.
RangeAddress = Range("A1:I" & Rows.count).Address
' Set the field that you want to filter in the range
' "1 = column A" in this example because the filter range
' starts in column A.
FilterField = 1
' Fill in the filter value. Use the "<>" if you want to
' filter on the absence of a term. Or use wildcards such
' as "ron*" for cells that start with ron, or use
' "*ron*" if you look for cells where ron is a part of the
' cell value.
SearchValue = "<>"
'**********************************************************
'**********************************************************
 
' Add a slash after MyPath if needed.
If Right(MyPath, 1) <> "" Then
MyPath = MyPath & ""
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files in the
' folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Change application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Select workbook and worksheet to paste the copied date into
Set BaseWks = ActiveWorkbook.Sheets("BaseData")
rnum = 1
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
' Set the filter range.
With mybook.Worksheets(ShName)
Set sourceRange = .Range(RangeAddress)
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
' Find the last row in target worksheet.
rnum = RDB_Last(1, BaseWks.Cells) + 1
With sourceRange.Parent
Set rng = Nothing
' Remove the AutoFilter.
.AutoFilterMode = False
' Filter the range on the
' value in filter column.
sourceRange.AutoFilter Field:=FilterField, _
Criteria1:=SearchValue
With .AutoFilter.Range
' Check to see if there are results
' after after applying the filter.
RwCount = .Columns(1).Cells. _
SpecialCells(xlCellTypeVisible).Cells.count - 1
If RwCount = 0 Then
' There is no data, only the
' header.
Else
' Set a range without the
' header row.
Set rng = .Resize(.Rows.count - 1, .Columns.count). _
Offset(1, 0).SpecialCells(xlCellTypeVisible)
 
' Copy the range and the file name
' in column A.
If rnum + RwCount < BaseWks.Rows.count Then
BaseWks.Cells(rnum, "A").Resize(RwCount).Value _
= mybook.Name
rng.Copy BaseWks.Cells(rnum, "B")
End If
End If
End With
'Remove the AutoFilter
.AutoFilterMode = False
End With
End If
' Close the workbook without saving.
mybook.Close savechanges:=False
End If
' Open the next workbook.
Next FNum
' Set the column width in the new workbook.
BaseWks.Columns.AutoFit
 
 
MsgBox "Look at the merge results in the workbook" & _
"after you click on OK."
End If
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
What I would like to do is to check whether the worksheet that is receiving the data (the BaseData sheet specified in the code) is empty (apart from header row which starts at A1) and, if it isn't, to clear the data before pasting anything from the other workbooks.

I would also like, if possible in the same macro to then format the pasted cells with borders all round. The columns in use are always A:J but the number of rows may vary (and there may or may not be data in any of the cells in Col J.

TIA.
Nicki

Hi Team,

Firstly i would like to thank this Forum and Moderators.

I had learned much from this and still need to learn.

I start my problem here i have a macro written with the help of Forum and my friend.But unable to create an button which can execute this macro.

Iam attaching the code as well.

Any help would be apprecaited.

Many thanks,
Shekar.

Sub KILDEL()
'
' KILDEL Macro
' Macro recorded 7/23/2008 by thontash
'
' Keyboard Shortcut: Ctrl+Shift+J
'
Dim pctdone As Single
Dim counter As Long
Dim i As Long
Dim rownum As Long
Dim pivotrow As Long
Dim usdpay As Double
Dim celln As Double
Dim rc As Double
Dim pc As Double
Dim j As Double
counter = 0
rownum = ActiveSheet.UsedRange.Rows.Count - 1 + ActiveSheet.UsedRange.Rows(1).Row
For i = rownum To 1 Step -1

If Cells(i, 9) = "PnL-USD" Then
Rows(i).Delete
End If

If Cells(i, 9) = "FX PnL posting" Then
Rows(i).Delete
End If

If Cells(i, 9) = "FX PnL Posting" Then
Rows(i).Delete
End If

If Cells(i, 9) = "PM pnl posting" Then
Rows(i).Delete
End If

If Cells(i, 9) = "pnl posting" Then
Rows(i).Delete
End If

If Cells(i, 9) = "PM PNL POSTING" Then
Rows(i).Delete
End If

If Cells(i, 9) = "PM PNL posting" Then
Rows(i).Delete
End If

If Cells(i, 9) = "PM PnL posting" Then
Rows(i).Delete
End If

If Cells(i, 9) = "CHF pnl posting" Then
Rows(i).Delete
End If


If Cells(i, 9) = "CPM pnl posing" Then
Rows(i).Delete
End If


If Cells(i, 9) = "FX PNL" Then
Rows(i).Delete
End If


If Cells(i, 9) = "FX pnl posting" Then
Rows(i).Delete
End If


If Cells(i, 9) = "PM pnl posing" Then
Rows(i).Delete
End If


If Cells(i, 9) = "PM PNL Posting" Then
Rows(i).Delete
End If


If Cells(i, 9) = "FX PNL Posting" Then
Rows(i).Delete
End If
counter = counter + 1

pctdone = counter / rownum
Call getpercentage1(pctdone)
Next i
Unload Userform1
ActiveSheet.UsedRange.Columns.AutoFit
 Range("A1").Select
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        "Sheet1!R1C1:R10000C20").CreatePivotTable TableDestination:="", TableName:= _
        "PivotTable1", DefaultVersion:=xlPivotTableVersion10
    ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
    ActiveSheet.Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Currency")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Movement")
        .Orientation = xlColumnField
        .Position = 1
    End With
    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
        "PivotTable1").PivotFields("Quantity"), "Sum of Quantity", xlSum
    ActiveWorkbook.ShowPivotTableFieldList = False
    Range("B5:E15").Select
    Selection.NumberFormat = "0"
    Range("F6").Select


   'Sheets("sheet2").Select
    Range("b25:b35").Clear
    For pivotrow = 1 To ActiveSheet.UsedRange.Rows.Count - 1 + ActiveSheet.UsedRange.Rows(1).Row
   
    If Cells(pivotrow, 1) = "USD" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b25")
      End If
   
   If Cells(pivotrow, 1) = "CAD" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b32")
   End If
   
   If Cells(pivotrow, 1) = "SEK" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b26")
   End If
   
  If Cells(pivotrow, 1) = "CHF" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b30")
   End If
   
  If Cells(pivotrow, 1) = "EUR" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b29")
   End If
   
  If Cells(pivotrow, 1) = "GBP" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b28")
   End If
   
  If Cells(pivotrow, 1) = "JPY" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b27")
   End If
   
   If Cells(pivotrow, 1) = "KRW" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b33")
   End If
   
   If Cells(pivotrow, 1) = "TWD" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b35")
   End If
   
   If Cells(pivotrow, 1) = "SGD" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b34")
   End If
   
   If Cells(pivotrow, 1) = "AUD" Then
     Cells(pivotrow, 2).Copy Sheets("Statistics").Range("b31")
   End If
   
   Next pivotrow
  
   Sheets("Statistics").Range("a5:f20").Copy Sheets("Statistics").Range("a3:f18")
 
  Sheets("Statistics").Range("a19").Value = MonthName(Month(Date)) & " " & Year(Date)
  
  celln = Sheets("Statistics").Range("c36").Value
  Sheets("Statistics").Range("c19").Value = celln
  
   pivotrow = 1
   Range("d25:d35").Clear
   For pivotrow = 1 To ActiveSheet.UsedRange.Rows.Count - 1 + ActiveSheet.UsedRange.Rows(1).Row
      
     If Cells(pivotrow, 1) = "USD" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D25")
     End If
   
   If Cells(pivotrow, 1) = "CAD" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D32")
   End If
   
   If Cells(pivotrow, 1) = "SEK" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D26")
   End If
   
  If Cells(pivotrow, 1) = "CHF" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D30")
   End If
   
   If Cells(pivotrow, 1) = "AUD" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D31")
   End If
   
  If Cells(pivotrow, 1) = "EUR" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D29")
   End If
   
  If Cells(pivotrow, 1) = "GBP" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D28")
   End If
   
  If Cells(pivotrow, 1) = "JPY" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D27")
   End If
   
   If Cells(pivotrow, 1) = "KRW" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D33")
   End If
   
   If Cells(pivotrow, 1) = "TWD" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D35")
   End If
   
   If Cells(pivotrow, 1) = "SGD" Then
     Cells(pivotrow, 3).Copy Sheets("Statistics").Range("D34")
   End If
   
   celln = Sheets("Statistics").Range("E36").Value
  Sheets("Statistics").Range("C20").Value = celln
   
   Next pivotrow
   Sheets("statistics").Activate
   'Range("C25").Copy Range("D25")
   
   Sheets("sheet1").Activate
   
  Sheets("Sheet1").Select
    Rows("1:1").Select
    Selection.AutoFilter
    Range("B2").Select
    Selection.AutoFilter Field:=2, Criteria1:="CASH"
    
      
End Sub
Sub getpercentage1(pct)
Userform1.Frameprogress.Caption = "Progress " & Format(pct, "0%")
Userform1.Labelprogress.Width = pct * (Userform1.Frameprogress.Width - 10)
Userform1.Repaint

End Sub
Sub getuserform1()
Userform1.Labelprogress.Width = 0
Userform1.Show

End Sub


Hi,

I am new to VBA coding.

I have code which sets column width, wrap text, align text in every worksheet...

Sub FormatWorksheets()

Dim I As Long
Application.ScreenUpdating = False

For I = 1 To Worksheets.Count
With Sheets(I)
'Set column widths:
.Columns("A:A").ColumnWidth = 11.86
.Columns("B:B").AutoFit
.Columns("C:C").ColumnWidth = 8.43
.Columns("D:D").ColumnWidth = 45.71
.Columns("E:E").ColumnWidth = 10
.Columns("F:F").ColumnWidth = 11.17
'Set column alignments; left/right/center:
.Columns("A:A").HorizontalAlignment = xlRight
.Columns("A:A").VerticalAlignment = xlCenter
.Columns("B:B").HorizontalAlignment = xlLeft
.Columns("B:B").VerticalAlignment = xlCenter
.Columns("C:C").HorizontalAlignment = xlCenter
.Columns("C:C").VerticalAlignment = xlCenter
.Columns("D:D").HorizontalAlignment = xlLeft
.Columns("D:D").VerticalAlignment = xlCenter
.Columns("E:E").HorizontalAlignment = xlCenter
.Columns("E:E").VerticalAlignment = xlCenter
.Columns("F:F").HorizontalAlignment = xlCenter
.Columns("F:F").VerticalAlignment = xlCenter
.Range("A1").HorizontalAlignment = xlCenter
.Columns("D:D").WrapText = True
.Rows("1:1").WrapText = True

End With
Next I

Application.ScreenUpdating = True
End Sub

What i want is to incorporate this another code into the above code which sets the header row for each worksheet

.PrintTitleRows = "$1:$1"

Also, if someone can incorporate a code to give all borders to all non-blank cell in each worksheet.

Hope, i m clear.

Pls help.

Hi,

i have an excel sheet that has stopped working since changing software to 2010. When i right click and select "add why" the vba code runs the stops at this line:


	VB:
	
Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes( _ 
strStartShape), 7 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
anyone had the same issue and know how to correct it? The full Add why sub is below:


	VB:
	
 AddWhy() 
    Dim strStartShape As String, strEndShape As String, iDropCount As Integer, _ 
    strConnector As String, lgColWidth As Long 
    UnprotectMe 
    Application.ScreenUpdating = False 
    iWidth = Range("width") 
    iHeight = Range("height") 
    lgColWidth = ActiveCell.Width 
    iFont = Range("font") 
    Set rgWhy = ActiveCell 
    Range("last_conn") = Range("last_conn") + 1 
    ActiveCell.Offset(1, 0) = Left(ActiveCell.Offset(1, 0), 8) & _ 
    "-" & Format(iWhys + 1, "00") 
    ActiveCell.Offset(0, 2).Select 
    If Cells(5, ActiveCell.Column) = Sheets(2).Range("languages"). _ 
    Columns(Sheets(2).Range("lang_setting")).Cells(8, 1) Then 'add another why column
        ActiveCell.Offset(0, -1).EntireColumn.Insert 
        ActiveCell.Offset(0, -1).EntireColumn.Insert 
        ActiveCell.ColumnWidth = iWidth 
        ActiveCell.Offset(0, -1).ColumnWidth = 4 
        Range("why_count") = Range("why_count") + 1 
        Cells(5, ActiveCell.Column) = Sheets(2).Range("languages"). _ 
        Columns(Sheets(2).Range("lang_setting")).Cells(7, 1) & " " & Range("why_count") 
        AutoFit Range("autofit") 
    End If 
    If iWhys > 0 Then 'find the last why
        iDropCount = 1 
        Do Until iDropCount = iWhys 
            ActiveCell.Offset(2, 0).Select 
            If IsEmpty(ActiveCell.Offset(1, 0)) = False Then iDropCount = iDropCount + 1 
        Loop 
        ActiveCell.Offset(2, 0).Select 
         
         'find next below or left full cell
        Do Until IsEmpty(ActiveCell.Offset(1, 0)) = False Or _ 
            ActiveCell.Offset(1, 0).End(xlToLeft).Column  1 Or _ 
            Cells(ActiveCell.Offset(1, 0).Row, 2).End(xlDown).Row = 65536 
            ActiveCell.Offset(2, 0).Select 
        Loop 
         
         
         
        Selection.Range("A1:A2").EntireRow.Insert 
        AutoFit Range("autofit") 
        With Selection.Range("A1:A2").EntireRow 
            .Borders(xlInsideVertical).LineStyle = xlNone 
            .Cells(1, 14 + 2 * Range("why_count")).Range("A1:A2").Borders(xlEdgeRight).Weight = xlMedium 
            .Locked = True 
            .Font.Italic = False 
        End With 
        Selection.RowHeight = iHeight 
        Selection.Offset(1, 0).RowHeight = 5 
    End If 
     
    strStartShape = ActiveSheet.Shapes.AddShape(msoShapeFlowchartConnector, _ 
    rgWhy.Left + lgColWidth, rgWhy.Top + iHeight / 2, 1, 1).Name 
    ActiveSheet.Shapes(strStartShape).Name = "start-" & Format(Range("last_conn"), "000") 
    strEndShape = ActiveSheet.Shapes.AddShape(msoShapeFlowchartConnector, _ 
    ActiveCell.Left, ActiveCell.Top + iHeight / 2, 1, 1).Name 
    ActiveSheet.Shapes(strEndShape).Name = "end-" & Format(Range("last_conn"), "000") 
    ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 453#, 55.5, 4.5, 53.25) _ 
    .Select 
    strConnector = "conn-" & Format(Range("last_conn"), "000") 
    Selection.Name = strConnector 
    Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle 
    Selection.ShapeRange.Flip msoFlipHorizontal 
    Selection.ShapeRange.Flip msoFlipVertical 
    Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes( _ 
    strStartShape), 7 
    Selection.ShapeRange.ConnectorFormat.EndConnect ActiveSheet.Shapes( _ 
    strEndShape), 3 
    ActiveCell.Select 
    With ActiveCell 
        .Locked = False 
        .FormulaHidden = False 
        .Font.Bold = False 
        .Font.Size = iFont 
        .HorizontalAlignment = xlLeft 
        .VerticalAlignment = xlCenter 
        .WrapText = True 
        .Font.ColorIndex = 0 
        .Borders(xlEdgeLeft).Weight = xlThin 
        .Borders(xlEdgeTop).Weight = xlThin 
        .Borders(xlEdgeBottom).Weight = xlThin 
        .Borders(xlEdgeRight).Weight = xlThin 
    End With 
    With ActiveCell.Offset(1, 0) 
        .Value = strConnector & "-00" 
        .Font.Bold = False 
        .Locked = True 
        .FormulaHidden = True 
        .Font.ColorIndex = 2 
    End With 
    CheckLastWhy 
    ProtectMe 
End Sub 

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


Hi,

I have 2 workbooks, one containing all my code and userforms and another containing all my data (which is continuously updated/dynamic). I want to be able to manipulate the data without ever opening the workbook (at the moment I use the open workbook method, but it is extremely slow). I have found some code (Jwalk) which I think meets my needs (and is instant). I have adapted this so it points to a specific path rather than the active path as below etc. but I need to adapt it further so that:

1. When the data is opened it is formatted exactly the same as it is in the original sheet which includes any coloured cells, bold fonts, cell width, height and so on

2. Any changes I make can be saved back to the original sheet in the closed workbook.

3. The data always opens in a named specific worksheet i.e. "TempSheet" which sits in the workbook containing the code (my code is called from a userform within this workbook).

The code I am using from Jwalk is as follows:


	VB:
	
 GetDataDemo() 
     
    Dim FilePath$, Row&, Column&, Address$ 
     
     'change constants & FilePath below to suit
     '***************************************
    Const FileName$ = "Book1.xls" 
    Const SheetName$ = "Sheet1" 
    Const NumRows& = 10 
    Const NumColumns& = 10 
    FilePath = ActiveWorkbook.Path & "" 
     '***************************************
     
    DoEvents 
    Application.ScreenUpdating = False 
    If Dir(FilePath & FileName) = Empty Then 
        MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist" 
        Exit Sub 
    End If 
    For Row = 1 To NumRows 
        For Column = 1 To NumColumns 
            Address = Cells(Row, Column).Address 
            Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address) 
            Columns.AutoFit 
        Next Column 
    Next Row 
    ActiveWindow.DisplayZeros = False 
End Sub 
 
Private Function GetData(Path, File, Sheet, Address) 
    Dim Data$ 
    Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _ 
    Range(Address).Range("A1").Address(, , xlR1C1) 
    GetData = ExecuteExcel4Macro(Data) 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I am still learning VBA and can adapt/write small pieces of simple code, I have tried incorporating the paste special method, but in all honesty, don't know what I am doing and it results in lots of errors. Can anyone help me get this working/point me in the right direction? Also, what does 'Const' do? how do I bring in the data without specifying the number of rows, as this will be different every time?

I spent some time searching the forum and found some helpful suggestions for using the autofit feature for merged cells. But this request is a variation of the of the code to Autofit row heights and column widths and does not involve merged cells.

Basically, I want to set it up so that when the user clicks or arrows over to a cell in column 3, 4 or 5, the row height will expand enough to allow them to read the contents of the cell.

The code I currently have in place is:


	VB:
	
 Range) 
    If Target.Column = 3 Then 
        ActiveCell.Rows.AutoFit 
    ElseIf Target.Column = 4 Then 
        ActiveCell.Rows.AutoFit 
    ElseIf Target.Column = 5 Then 
        ActiveCell.Rows.AutoFit 
    Else 
        Rows.RowHeight = 12.75 
    End If 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
This works, insofar as it's doing what I've told it to do. But here are the caveats:

1) When the row is autofitted, it works a little too efficiently and autofits to the maximum height needed for all cells in that row. So if the active cell is C4 and there are 3 lines in that cell, but E4 has 14 lines in its cell, the autofit will be effected for the height needed for E4. But when I'm on cell C4, I only want the row height to increase enough to see the entire contents of C4. Otherwise, I'm seeing a lot of unnecessary whitespace. It seems to me that I should be able to have it determine the maximum height necessary for that particular cell based on the content of the cell and then increase the row height to that amount. I considered and tried pulling the Height and assigning it to a variable that would then be used for adjusting the Row Height, but the height did not adjust. I think that may have been because Height was pulling the actual current height of the row, and not the height if the row were autofitted to the contents of that one cell. But my experience with VBA is weak and there are some significant gaps (or chasms, abyss...) in my understanding, so any explanations would be appreciated.

2) Currently, if the active cell is C4 and I use the arrow keys or mouse to navigate to column B, the row height returns to 12.75. I would like to expand on that and say that if I'm on C4 and I navigate up to C3 without changing columns, row 3 should expand appropriately (which it does) while row 4 returns to the 12.75 row height (which does not happen). That basically keeps it clean, and makes sure that only one row is ever expanded at a time. I tried adding

	VB:
	
 Target.Rows.Count = 1 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
But all that did was stop everything from working - no errors, it just didn't autofit any more. Again, I suspect that I just don't fully understand how Rows.Count should be used in this situation.

I've attached an example so that you can see how it is currently set up. Just as background, the file will be used as a checkout document, which is why the rows should generally be set at 12.75 (so you can scroll through and easily determine what has passed, what has failed and what still needs to be done), but it is also acting as documentation, which is why the row heights need to be increased for readability.

Ok, I've got the following code in a macro that is supposed to autofit a column up to a certain width. The autofit part works fine, but when it gets a column over the specified limit and tried to reset the width, it chokes. Gives me an error "Could not set ColumnWidth property of range object."

Columns(Col).EntireColumn.AutoFit
If Columns(Col & ":" & Col).Width > 528.75 Then
Columns(Col).ColumnWidth = 528.75
End If

Anyone know why this would be?

Edit: FYI, "Col" is a variable passed to this function, which is simply the column letter as a string.

Last week, Art was trying to help me with this, but the solution doesn't work
for me. I'm looking for a macro that would be contained within my
personal.xls, that I could use as needed.

Lets say I have A1:C5 selected, which represent headdings and data for jan,
feb and march. [On a different spreadsheet, it may be different columns, or
a different number of columns. The point is that I will select the range
before I run the macro.]

I want to do an auto fit for each column, so that the column widths are big
enough to fit the numbers. No problem, format-->column-->autofit and I'm
done.

But once that is done (for example), the width of column A is 15, column B
is 7 and column C is 13. When you print the spreadsheet, it will look much
better if all the column widths are the same. So, since column A is the
largest, I would want all three columns sized to 15.

So, essentially I would like a macro that looks at the selection, does an
autofit on the column widths, checks the column width of all the columns
within the selection, and then makes all the columns the same width as the
largest column.

Is it possible to do this all within personal.xls and not have to add macros
to each spreadsheet that I use it on?

"Jonathan Cooper" wrote:

> your not the first person to say that to me! If I could just find time to
> learn VBA, I could drive myself crazy instead!
>
> My intent was to insert this macro into my personal workbook, and assign it
> to a button on my shortcut bar, so that I can use it as a utility for various
> other spreadsheets.
>
> Will this work for that purpose?
>
> "Art" wrote:
>
> > Jonathan, you're making this harder!
> >
> > Okay, how about this:
> >
> > Put the following macro in the sheet you're working on:
> >
> > Private Sub Worksheet_SelectionChange(ByVal Target As Range)
> > x = Target.Columns.Address
> > End Sub
> >
> > Now, put this in a separate module:
> >
> > Public x As String
> >
> > Sub DoColumns()
> > Dim w As Integer
> > Dim i As Integer
> > Dim r As Range
> > w = 0
> > Columns(x).AutoFit
> > For Each r In Range(x)
> > If r.ColumnWidth > w Then w = r.ColumnWidth
> > Next r
> > Columns(x).ColumnWidth = w
> > End Sub
> >
> > This will only work on adjacent columns in that sheet. Select your columns.
> > Then, using Tools/Macro/Macros, run the DoColumns macro.
> >
> > With any luck this will work.
> >
> > Art
> >
> >
> > "Jonathan Cooper" wrote:
> >
> > > Can you change it so that it works, regardless of of the specific columns or
> > > number of columns i have in my selection?
> > >
> > > "Art" wrote:
> > >
> > > > Jonathan,
> > > >
> > > > Try this:
> > > >
> > > > Sub temp()
> > > > Dim w As Integer
> > > > Dim i As Integer
> > > > w = 0
> > > > Columns("A:C").AutoFit
> > > > For i = 1 To 3
> > > > If Columns(i).ColumnWidth > w Then w = Columns(i).ColumnWidth
> > > > Next i
> > > > Columns("A:C").ColumnWidth = w
> > > > End Sub
> > > >
> > > > Art
> > > >
> > > > "Jonathan Cooper" wrote:
> > > >
> > > > > Here is what I would like to be able to do. This is really a
> > > > > formatting/presentation issue:
> > > > >
> > > > > Lets say I have A1:C5 selected, which represent headdings and data for jan,
> > > > > feb and march.
> > > > >
> > > > > I want to do an auto fit for each column, so that the column widths are big
> > > > > enough to fit the numbers. No problem, format-->column-->autofit and I'm
> > > > > done.
> > > > >
> > > > > But once that is done (for example), the width of column A is 15, column B
> > > > > is 7 and column C is 13. When you print the spreadsheet, it will look much
> > > > > better if all the column widths are the same. So, since column A is the
> > > > > largest, I would want all three columns sized to 15.
> > > > >
> > > > > So, essentially I would like a macro that looks at the selection, does and
> > > > > autofit on the column widths and then makes all three columns the same width
> > > > > as the largest column.
> > > > >
> > > > > Ideas?

If you want to try to split the text among multiple cells, you could try the
following macro. I use it when I write paragraphs of text that go beyond the
right margin of the page. It only works on one column at a time, but can do
multiple rows. Widen your column to set where you want the text wrapped
(column width dictates where the text is split), select the cell(s) you want
wrapped, run the macro, then change your column width back to where it was
originally.

I know there is a better/easier/more efficient way to write this, but I
wrote the macro back when I was just learning VBA and never went back to
streamline it.

Be sure to back up your data.

Sub text_wrap()

Dim ColWidth As Single
Dim SelectionAddress As Variant
Dim Rw As Integer
Dim SplitTextString As Variant
Dim Count1 As Integer
Dim Count2 As Integer
Dim StartRange As Variant
Dim TextString As String

ColWidth = Selection.ColumnWidth
Rw = Selection.Rows.Count
StartRange = ActiveCell.Address
SelectionAddress = Selection.Address

For Each x In Range(SelectionAddress)
If x.Value = "" Then TextString = TextString & "_"
TextString = TextString & x.Value & " "
x.Value = ""
Next x

SplitTextString = Split(TextString, " ", -1, vbTextCompare)

Range(StartRange).Select
Selection.EntireColumn.Insert
Selection.ColumnWidth = ColWidth
Count1 = 0
Count2 = 1

Do While Count1 Rw And Count1 < UBound(SplitTextString) - 1 _
Then Selection.EntireRow.Insert
Count1 = Count1 + 1
Loop
If Count1 < UBound(SplitTextString) Then
Selection.Value = Selection.Value & SplitTextString(Count1) & " "
Selection.EntireColumn.AutoFit
Count1 = Count1 + 1
End If
Loop
If Count1 0 Then
Selection.Value = Left(Selection.Value, Len(Selection.Value) - 1)
Selection.EntireColumn.AutoFit
If Selection.ColumnWidth > ColWidth Then
Selection.Value = Left(Selection.Value, Len(Selection.Value) - _
Len(SplitTextString(Count1 - 1)) - 1)
Count1 = Count1 - 1
End If
Selection.ColumnWidth = ColWidth
ActiveCell.Offset(0, 1).Value = Selection.Value
ActiveCell.Offset(1, 0).Select
Count2 = Count2 + 1
If Count2 > Rw And Count1 < UBound(SplitTextString) _
Then Selection.EntireRow.Insert
End If
Loop

Selection.EntireColumn.Delete

End Sub

"Rob" wrote:

> Hello anyone...
> I hope that you can help me w/ this situation. I have a spreadsheet w/
> alot of text in "one" cell. When I Format->Cells->Alignment-> and
> choose wrap text. It wraps the text until you get to the end of the
> cell. At the end of the cell the text continues pass the right border.
> I tried ajusting the "rows" hieght, but the text still continues, and I
> have about 2 inchs of white space in the cell where I want this text to
> wrap to. I increase the width of the column, but the text aligns to the
> top and keeps going up as I widen the column. Plus widening the column
> is not an option that the user wants on the spreadsheet, but I got
> desperate. I have looked in my "Options" in the "Tool" menu. I know I
> most likely choose every option in that dialog box. Still no results. I
> have been working on this all day. My brain is now mushhhh Pls
> help....
>
>

I have recorded a macro to alter basic formatting of a worksheet i.e column width, wrap text, font size, page setup etc which is necessary when downloading our budget statements from our new report writer. I have tried to add in a command to VBA which will run this macro in ALL worksheets in the workbook (a variable amount - between 5 and 50) however the best I can manage is that some of the formatting works yet not all.

Is there a simple command I can enter which will allow me to format the entire workbook at once?

I'll post the code below for review if anyone can help.

Many thanks.

Dim iwsCount As Integer
Dim I As Integer

' Set 'wsCount equal to the number of worksheets in the active workbook
iwsCount = ActiveWorkbook.Worksheets.Count

' Begin the Loop
For I = 1 To iwsCount


Cells.Select
    With Selection.Font
        .Name = "Arial"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
       End With
    ActiveWindow.Zoom = 80
    Selection.ColumnWidth = 11.43
    Rows("1:3").Select
    With Selection
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows("3:3").Select
    Selection.RowHeight = 44.25
    Columns("A:A").EntireColumn.AutoFit
    Columns("I:I").EntireColumn.AutoFit
    Columns("J:J").EntireColumn.AutoFit
    Cells.Select
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.75)
        .RightMargin = Application.InchesToPoints(0.75)
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(1)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    Range("A1").Select
     
Next I
    
End Sub
Cheers guys.

Is there a way to combine two cells in to a third cell such that the first
cell's value is left justified and the 2nd cell's value is right justified.
Like a left-tab and a right-tab would do in word.

A1 = "Coffee" {which is left justified in the cell}
B1 = "1010" {which is right Justified in the cell}
C1 = "Coffee 1010" {which does not
have the physical spaces added, this should be controlled by auto-fit in the
cell based on the data in the entire column-C} Of course I could use fixed
font and always make the cell have 50 characters for example... but I want
this to work with proportional fonts.

Something like... =LeftJust(A1)&RightJust(B1) -or-
=A1&RTabChar&B1

Maybe a VBA function that plops the text into a cell and autofits then
calculates the width then iterates thought adding a space and recalculating
the width until the needed width is reached. This method still has problems
because proportional fonts spacing will not come out exact across multiple
strings of text.

Verbose - I know but there has to be a better way. (I know this square peg
WILL fit in that round hole)

--
Regards,
John

How would I pass information from an Excel VBA module to an Access
query using ADO? At the moment I can run the report if I hard code the
parameters into the query but that is a bit pointless.

I run this report in Access at the moment and have a user form setup
that allows the user to specify their own parameters. The report is
then output to an Excel spreadhseet. As I intend to further manipulate
the data in Excel it would be better if Excel could be in charge from
the start.

I have included the VBA code below.

Public Sub SavedQuery()

Dim objField As ADODB.field
Dim rsData As ADODB.Recordset
Dim lOffset As Long
Dim sxConnect As String

'Create the connection string
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=J:linktolivelinktolive.mdb;"

'Create the recordset object and run the query
Set rsData = New ADODB.Recordset

rsData.Open "[ADOFalkirkPriorityArrivals]", szConnect,
adOpenForwardOnly, _
adLockReadOnly, adCmdTable

'Make sure we get records back
If Not rsData.EOF Then

'Dump the contents of the recordset onto the worksheet
Sheet1.Range("A2").CopyFromRecordset rsData
'Fit the column widths to the data
Sheet1.UsedRange.EntireColumn.AutoFit
Sheet1.UsedRange.EntireRow.RowHeight = 20

Else
MsgBox "Error: No records returned.", vbCritical
End If

'Close the recordset
rsData.Close
Set rsData = Nothing

End Sub

Dear all,

I'm having some trouble with 2 issues regarding Pivot tables using vba:
1) how to autosize the colum width of a pivot table to adjust to the largest length of a value in the rows of the column
2) how to hide the rows pertaining to a particular colum

I've tried in vain

for 1) .TableRange1.EntireColumn.AutoFit

for 2) Worksheets("PivotReport").PivotTables(1).PivotFields("Item").Visible = False

Each time I get a '438' error

Help would be greatly appreciated.

Thks - Eric

If anyone is interested, I found a way to automatically adjust a row height based on merged cells text. Here's how I did it...

In a cell unmerged and on the same row as the merged cells, enter the formula = merged cells and set the formula cell to the same column width as the combined merged cells. For example: Merged cells are B2:D2, formula in F2 is "=B2". Then set column F width to match merged cells. So if the merged cells combined column width is 30, set column F width 30.

Then in the worksheet VBA, use this code. This will automatically adjust the row height after the text in cell B2 is entered.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 2 Then
ActiveSheet.Rows(2).AutoFit
End If
End Sub

Happy VBAing.


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