Macro adjustment

Last Edited By Krjb Donovan
Last Updated: Mar 05, 2014 09:45 PM GMT

Question

, I have macro here that needs adjustment. Basically what this macro is suppose to do is select the value from a drop down and go to another worksheet (titled "master) and retrive all the information matching that value along the row. however currently it is not doing that. The macro is below --X-- Sub PopulateData()

   Dim LCIMOutlet As Integer
   
   Dim LSAPNumber As String
   Dim LRegion As String
   
   Dim LRow As Long
   Dim LFound As Boolean
   
   'Retrieve project number number
   LCIMOutlet = Range("L4").Value
   
   'Move to Sheet1
   Sheets("Master").Select
   
   LFound = True
   
   LRow = 2
   
   Do While LFound = False
       'Found matching project, now update address and phone number information on Sheet2
       If Range("B" & LRow).Value = LCIMOutlet Then
           LFound = True
           LSAPNumber = Range("C" & LRow).Value
           LRegion = Range("D" & LRow).Value
           
           Sheets("Sheet2").Select
           Range("K6").Value = LSAPNumber
           Range("K8").Value = LRegion
           
       'Encountered a blank project number (assuming end of list on Sheet1)
       ElseIf IsEmpty(Range("B" & LRow).Value) = True Then
           MsgBox ("No match was found for combo box selection.")
           Exit Sub
       End If
       
       LRow = LRow + 1
   Loop
   

End Sub

Answer

Vish,

 LFound = True
  
  LRow = 2
  
  Do While LFound = False


that says to loop while Lfound = False, but when you first get there you have set lFound = true so the loop is never entered. I would suggest

 LFound = False
  
  LRow = 2
  
  Do While LFound = False


I can't say the code will then do all that you want, but that should eliminate your major problem.


Question

, I have a small macro that needs a slight adjustment. The objective of the macro is to split values into different worksheet everytime a change in Column A occurs. I.E Create a differnt worksheet when Column A number changes from 1 to 2. Currently it is creating additional worksheet which i dont need it to do, also the name of the worksheet should ONLY represent the value in column A. Macro is below Sub Splitter()

   n = 2

Again:

   lastn = Evaluate("match(true,A" & n & "<>OFFSET(A" & n & ",1,0,20000,1),0)") + n - 1
   from = Cells(n, 1).Value
   too = Cells(lastn + 1, 1).Value
   If too = "" Then too = "end"
   Worksheets.Add.Name = from & " - " & too
   Sheet1.Range("A" & n & ":H" & lastn).Copy Sheets(from & " - " & too).Range("A2")
   Sheets(from & " - " & too).Range("A1:H1").Value = Array("store_No", "Fixture Type", "POG Name", "Position", "Title", "UPC", "Vendor Name", "Item Nbr")
   n = lastn + 1
   Sheet1.Select
   If Cells(n, 1).Value <> "" Then GoTo Again

End Sub

Answer

Vish,

so are you saying that there are already worksheets named for the values in column A - that is my assumption of what you are asking.


Anyway, this code should handle the situation whether they exist or not:

Sub Splitter() Dim sh1 As Worksheet, sh As Worksheet Dim n As Long, first As Long, last As Long Dim i As Long

  Set sh1 = ActiveSheet
  n = 2
  first = 2
  last = sh1.Cells(sh1.Rows.Count, 1).End(xlUp).Row
  For i = n To last
  If sh1.Cells(i, 1) <> sh1.Cells(i + 1, 1) Then
   Set sh = Nothing
   On Error Resume Next
     Set sh = Worksheets(sh1.Cells(i, 1).Text)
   On Error GoTo 0
   If sh Is Nothing Then
      Worksheets.Add After:=Worksheets(Worksheets.Count)
      Worksheets(Worksheets.Count).Name = sh1.Cells(i, 1).Text
      Set sh = Worksheets(Worksheets.Count)
      sh.Range("A1:H1").Value = Array("store_No", _
      "Fixture Type", "POG Name", "Position", "Title", _
      "UPC", "Vendor Name", "Item Nbr")
   End If
   sh1.Range(sh1.Cells(first, 1), _
      sh1.Cells(i, 1)).Resize(, 8).Copy _
      sh.Cells(sh.Rows.Count, 1).End(xlUp).Offset(1, 0)
   first = i + 1
  End If
  Next i

End Sub

tested against my understanding of what you want to do and it worked for me. Obviously I could have a faulty understanding, so test this on a copy of your workbook until you are satisfied it works as you want.


Question

QUESTION: , I have a macro here that is suppose to adjust the print parameters but cant seem to adjust so that it fits all of the information onto one page. Macro is below Vish

Sub ShowPrintParameters() ' Keyboard Shortcut: Ctrl+t ' ' Dim sh1 As Worksheet, bk As Workbook Dim sh As Worksheet, sPath As String Dim sName As String, rw As Long Set sh1 = ActiveSheet

With Application.FileDialog(msoFileDialogFolderPicker)

  .InitialFileName = "C:\Documents and Settings\nishantm\Desktop\rob\"
  .Title = "Please selected the folder containing the files you would like to consolidate."
  .Show
  If .SelectedItems.Count = 0 Then
      Exit Sub
  Else
      sPath = .SelectedItems(1) & "\"
  End If

End With


sName = Dir(sPath & "*.xls") rw = 2 Do While sName <> ""

Set bk = Workbooks.Open(sPath & sName) sh1.Cells(rw, 1) = bk.Name For Each sh In bk.Worksheets sh.Activate sh1.Cells(rw, 2) = sh.Name Set r = sh.UsedRange If r.Width > 0.5 * r.Height Then

s = xlLandscape

Else

s = xlPortrait

End If

sh.PageSetup.Orientation = s sh.PageSetup.CenterHorizontally = True sh.PageSetup.CenterVertically = True

sh1.Cells(rw, 1) = r.Width sh1.Cells(rw, 1) = r.Height sh1.Cells(rw, 1) = s

   With sh.PageSetup
      .LeftMargin = Application.InchesToPoints(0)
      .RightMargin = Application.InchesToPoints(0)
      .TopMargin = Application.InchesToPoints(0)
      .BottomMargin = Application.InchesToPoints(0)
      .HeaderMargin = Application.InchesToPoints(0)
      .FooterMargin = Application.InchesToPoints(0)
      .PrintHeadings = True
      .PrintGridlines = False
      .FitToPagesWide = 1
      .FitToPagesTall = 1
      .PrintErrors = xlPrintErrorsDisplayed
   End With

rw = rw + 1 Next sh

'save the changes done to center the worksheet horizontally and vertically for printing bk.Close SaveChanges:=True

sName = Dir() Loop

End Sub


ANSWER: Vish,

when you use

  .FitToPagesWide = 1
  .FitToPagesTall = 1

you also need to set Zoom to false

  .Zoom = False
  .FitToPagesWide = 1
  .FitToPagesTall = 1


Hopefully it is as simple as that.


Sub ShowPrintParameters() ' Keyboard Shortcut: Ctrl+t ' ' Dim sh1 As Worksheet, bk As Workbook Dim sh As Worksheet, sPath As String Dim sName As String, rw As Long Set sh1 = ActiveSheet

With Application.FileDialog(msoFileDialogFolderPicker)

 .InitialFileName = "C:\Documents and Settings\nishantm\Desktop\rob\"
 .Title = "Please selected the folder containing the files you would like to consolidate."
 .Show
 If .SelectedItems.Count = 0 Then
     Exit Sub
 Else
     sPath = .SelectedItems(1) & "\"
 End If

End With


sName = Dir(sPath & "*.xls") rw = 2 Do While sName <> ""

Set bk = Workbooks.Open(sPath & sName) sh1.Cells(rw, 1) = bk.Name For Each sh In bk.Worksheets sh.Activate sh1.Cells(rw, 2) = sh.Name Set r = sh.UsedRange If r.Width > 0.5 * r.Height Then s = xlLandscape Else s = xlPortrait End If

sh.PageSetup.Orientation = s sh.PageSetup.CenterHorizontally = True sh.PageSetup.CenterVertically = True

sh1.Cells(rw, 1) = r.Width sh1.Cells(rw, 1) = r.Height sh1.Cells(rw, 1) = s

  With sh.PageSetup
     .LeftMargin = Application.InchesToPoints(0)
     .RightMargin = Application.InchesToPoints(0)
     .TopMargin = Application.InchesToPoints(0)
     .BottomMargin = Application.InchesToPoints(0)
     .HeaderMargin = Application.InchesToPoints(0)
     .FooterMargin = Application.InchesToPoints(0)
     .PrintHeadings = True
     .PrintGridlines = False
     .Zoom = False
     .FitToPagesWide = 1
     .FitToPagesTall = 1
     .PrintErrors = xlPrintErrorsDisplayed
  End With

rw = rw + 1 Next sh

'save the changes done to center the worksheet horizontally and vertically for printing bk.Close SaveChanges:=True

sName = Dir() Loop

End Sub


---------- FOLLOW-UP ----------

QUESTION: , The macro above works perfectly now. Just one more question Can we add a parameter that enables it to provide a summary of the workbook and worksheet it has looped through and adjusted? And the adjustments it has made i.e from landscape to portraite Thanks Vish

Answer

Vish,

perhaps this:

Sub ShowPrintParameters() ' Keyboard Shortcut: Ctrl+t ' ' Dim sh1 As Worksheet, bk As Workbook, r As Range Dim sh As Worksheet, sPath As String, s As Variant Dim sName As String, rw As Long, rw2 As Long, sh2 As Worksheet Dim l As Long Set sh1 = ActiveSheet ' add a sheet as the end to record the changes made Application.ScreenUpdating = False Worksheets.Add after:=Worksheets(Worksheets.Count) Set sh2 = Worksheets(Worksheets.Count) sh1.Activate Application.ScreenUpdating = True sh2.Range("A1:G1") = Array("Workbook", "Worksheet", "Changed from", "Changed to", _

 "Height", "Width", "Constant")

sh2.Range("A1:G1").Font.Bold = True rw2 = 2 With Application.FileDialog(msoFileDialogFolderPicker)

.InitialFileName = "C:\Documents and Settings\nishantm\Desktop\rob\"
.Title = "Please selected the folder containing the files you would like to consolidate."
.Show
If .SelectedItems.Count = 0 Then
    Exit Sub
Else
    sPath = .SelectedItems(1) & "\"
End If

End With


sName = Dir(sPath & "*.xls") rw = 2 Do While sName <> ""

Set bk = Workbooks.Open(sPath & sName) sh2.Cells(rw2, 1) = bk.Name For Each sh In bk.Worksheets sh.Activate sh2.Cells(rw2, 2) = sh.Name l = sh.PageSetup.Orientation If l = 1 Then

 sh2.Cells(rw2, 3) = "Portrait"

Else

 sh2.Cells(rw2, 3) = "Landscape"

End If Set r = sh.UsedRange If r.Width > 0.5 * r.Height Then s = xlLandscape sh2.Cells(rw2, 4) = "Landscape" Else s = xlPortrait sh2.Cells(rw2, 4) = "Portrait" End If

sh.PageSetup.Orientation = s sh.PageSetup.CenterHorizontally = True sh.PageSetup.CenterVertically = True

sh2.Cells(rw2, 6) = r.Width sh2.Cells(rw2, 5) = r.Height sh2.Cells(rw2, 7) = s

 With sh.PageSetup
    .LeftMargin = Application.InchesToPoints(0)
    .RightMargin = Application.InchesToPoints(0)
    .TopMargin = Application.InchesToPoints(0)
    .BottomMargin = Application.InchesToPoints(0)
    .HeaderMargin = Application.InchesToPoints(0)
    .FooterMargin = Application.InchesToPoints(0)
    .PrintHeadings = True
    .PrintGridlines = False
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
    .PrintErrors = xlPrintErrorsDisplayed
 End With

rw = rw + 1 rw2 = rw2 + 1 Next sh

'save the changes done to center the worksheet horizontally and vertically for printing bk.Close SaveChanges:=True

sName = Dir() Loop

End Sub



Question

Hi Jan, I have a macro here that set the print parameter, but i cant seem to figure out why it is not setting the parameter of "Fit To one Page" even though I've included into the macro. Vish Sub ShowPrintParameters() ' Keyboard Shortcut: Ctrl+t ' ' Dim sh1 As Worksheet, bk As Workbook Dim sh As Worksheet, sPath As String Dim sName As String, rw As Long Set sh1 = ActiveSheet

With Application.FileDialog(msoFileDialogFolderPicker)

  .InitialFileName = "C:\Documents and Settings\nishantm\Desktop\rob\"
  .Title = "Please selected the folder containing the files you would like to consolidate."
  .Show
  If .SelectedItems.Count = 0 Then
      Exit Sub
  Else
      sPath = .SelectedItems(1) & "\"
  End If

End With


sName = Dir(sPath & "*.xls") rw = 2 Do While sName <> ""

Set bk = Workbooks.Open(sPath & sName) sh1.Cells(rw, 1) = bk.Name For Each sh In bk.Worksheets sh.Activate sh1.Cells(rw, 2) = sh.Name Set r = sh.UsedRange If r.Width > 0.5 * r.Height Then

s = xlLandscape

Else

s = xlPortrait

End If

sh.PageSetup.Orientation = s sh.PageSetup.CenterHorizontally = True sh.PageSetup.CenterVertically = True

sh1.Cells(rw, 1) = r.Width sh1.Cells(rw, 1) = r.Height sh1.Cells(rw, 1) = s

   With sh.PageSetup
      .LeftMargin = Application.InchesToPoints(0)
      .RightMargin = Application.InchesToPoints(0)
      .TopMargin = Application.InchesToPoints(0)
      .BottomMargin = Application.InchesToPoints(0)
      .HeaderMargin = Application.InchesToPoints(0)
      .FooterMargin = Application.InchesToPoints(0)
      .PrintHeadings = True
      .PrintGridlines = False
      .FitToPagesWide = 1
      .FitToPagesTall = 1
      .PrintErrors = xlPrintErrorsDisplayed
   End With

rw = rw + 1 Next sh

'save the changes done to center the worksheet horizontally and vertically for printing bk.Close SaveChanges:=True

sName = Dir() Loop

End Sub


Answer

Not sure why, but using this seems to do the trick:

               .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
               .PrintQuality = -1
               .CenterHorizontally = False
               .CenterVertically = False
               .Orientation = xlPortrait
               .Draft = False
               .PaperSize = xlPaperA4
               .FirstPageNumber = xlAutomatic
               .Order = xlDownThenOver
               .BlackAndWhite = False
               .Zoom = False
               .FitToPagesWide = 1
               .FitToPagesTall = 1
               .PrintErrors = xlPrintErrorsDisplayed


Question

QUESTION: Hi Isaac, I have a macro below that needs slight adjustment that i cant seem to figure out. The problem is that the macro loops through the files and adjusts the print orientation of the files to the criteria i've set, however i cant seem to add a criteria where it sets the margins at "0" inches across the page. The macro is below ---X--- Sub ShowPrintParameters() ' Keyboard Shortcut: Ctrl+t ' ' Dim sh1 As Worksheet, bk As Workbook Dim sh As Worksheet, sPath As String Dim sName As String, rw As Long Set sh1 = ActiveSheet

With Application.FileDialog(msoFileDialogFolderPicker)

   .InitialFileName = "C:\Documents and Settings\nishantm\Desktop\rob\"
   .Title = "Please selected the folder containing the files you would like to consolidate."
   .Show
   If .SelectedItems.Count = 0 Then
       Exit Sub
   Else
       sPath = .SelectedItems(1) & "\"
   End If

End With


sName = Dir(sPath & "*.xls") rw = 2 Do While sName <> ""

Set bk = Workbooks.Open(sPath & sName) sh1.Cells(rw, 1) = bk.Name For Each sh In bk.Worksheets sh.Activate sh1.Cells(rw, 2) = sh.Name Set r = sh.UsedRange If r.Width > 0.5 * r.Height Then

 s = xlLandscape

Else

 s = xlPortrait

End If

sh.PageSetup.Orientation = s sh.PageSetup.CenterHorizontally = True sh.PageSetup.CenterVertically = True

sh1.Cells(rw, 1) = r.Width sh1.Cells(rw, 1) = r.Height sh1.Cells(rw, 1) = s rw = rw + 1 Next sh

'save the changes done to center the worksheet horizontally and vertically for printing bk.Close SaveChanges:=True

sName = Dir() Loop

End Sub

ANSWER: Right before this line:

rw = rw + 1


I would add this block of code: ______________________________________________________________________________ With sh.PageSetup

       .LeftMargin = Application.InchesToPoints(0)
       .RightMargin = Application.InchesToPoints(0)
       .TopMargin = Application.InchesToPoints(0)
       .BottomMargin = Application.InchesToPoints(0)
       .HeaderMargin = Application.InchesToPoints(0)
       .FooterMargin = Application.InchesToPoints(0)

End With ______________________________________________________________________________

If you really want to set margins to zero?

---------- FOLLOW-UP ----------

QUESTION: Hi Isaac, Thank you so much for your help, just wanted to ask a follow regarding fit to one page parameter. I want to be able to fit all of the information(Headers) into one page with the margins set at 0. I tried adding

.FitToPagesWide = 1
.FitToPagesTall = 1

after the last line of ".FooterMargin..." but was not able to accomplish my parameter. So just wanted to know how can i add a fit to one page paramter on the macro. I've only made the adjustments recomended by you, so did not want to send you another duplicate of the macro

ANSWER: to be honest with you, this kind of code, is not something I really know or memorize, I think few people do - cuz the macro recorder can spit out the code for you and who wants to memorize this crap? LOL

So the last code I posted was something I recorded with macro recorded, I Just tweaked it from saying With ActiveSheet.PageSetup, to fit your object "sh", and I suggested where to put it in your code.

Anyway having said all that, I got the same result you did, in terms of the

       .FitToPagesWide = 1
       .FitToPagesTall = 1

So how does it not work you mean you get an error? or what happens in regard to the fit?

---------- FOLLOW-UP ----------

QUESTION: No it just doesn't fit to one page, it separates the last 2 columns onto another page instead all of the headers in one page.(hopefully that makes). And where did you place those 2 parameters? Main purpose of this macro is that it should fit all of the information onto one page, instead of splitting the columns into different pages. Vish

Answer

I would place them in the With statement:

With sh.PageSetup

      .LeftMargin = Application.InchesToPoints(0)
      .RightMargin = Application.InchesToPoints(0)
      .TopMargin = Application.InchesToPoints(0)
      .BottomMargin = Application.InchesToPoints(0)
      .HeaderMargin = Application.InchesToPoints(0)
      .FooterMargin = Application.InchesToPoints(0)
      .FitToPagesWide = 1
      .FitToPagesTall = 1

End With


Is there something else that can be changing the print settings before the code prints it? I actually don't see any code that prints it out??

Question

Hi I have a macro here that I've created but seem to hit a wall. The main objective of this macro is to loop through a folder with 100+files and sort column E ascending. The macro is below. Sub Macro1() ' ' ' Dim wk As Workbook Dim s As Worksheet Dim addre As String Dim shtOrigin As String Dim Rnge As String With Application.FileDialog(msoFileDialogFolderPicker)

   .InitialFileName = "C:\"
   .Title = "Please Select the Folder to Loop"
   .Show
   If .SelectedItems.Count = 0 Then
       Exit Sub
   Else
       sPath = .SelectedItems(1) & "\"
   End If

End With

sName = Dir(sPath & "*.xls") rw = 2 Do While sName <> ""

   Set bk = Workbooks.Open(sPath & sName)
   sh1.Cells(rw, 1) = bk.Name
   For Each sh In bk.Worksheets
   sh.Activate
   sh1.Cells(rw, 2) = sh.Name
   Set r = sh.UsedRange
   Range("E:E").Select
   Selection.Sort Key1:=Range("E:E"), Order1:=xlAscending, Header:=xlGuess, _
   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBot_
   DataOption1:=xlSortNormal
   
   'save the changes done to center the worksheet horizontally and vertically for printing
   bk.Close SaveChanges:=True
   
   sName = Dir()

Loop

End Sub


Answer

Vish,


Macro1() ' ' ' Dim bk As Workbook Dim sh As Worksheet Dim sPath as String, sName as String Dim r as Range

With Application.FileDialog(msoFileDialogFolderPicker)

  .InitialFileName = "C:\"
  .Title = "Please Select the Folder to Loop"
  .Show
  If .SelectedItems.Count = 0 Then
      Exit Sub
  Else
      sPath = .SelectedItems(1) & "\"
  End If

End With

sName = Dir(sPath & "*.xls*")

Do While sName <> ""

  Set bk = Workbooks.Open(sPath & sName)
  For Each sh In bk.Worksheets
    set r = sh.Range("A1").currentRegion
    r.Sort Key1:=sh.Range("E1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBot   Next
  'save the changes done to center the worksheet horizontally and vertically for printing
  bk.Close SaveChanges:=True
  
  sName = Dir()

Loop

End Sub

Advertisement

©2017 eLuminary LLC. All rights reserved.