How do you set just a general macro on your keyboard?

Macro adjustment

• , 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 , 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 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 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 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 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, 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. 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. 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 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 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?? 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