Macro adjustment
QuestionEdit
, 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
AnswerEdit
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.
QuestionEdit
, 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
AnswerEdit
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.
QuestionEdit
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
AnswerEdit
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
QuestionEdit
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
AnswerEdit
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
QuestionEdit
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
AnswerEdit
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??
QuestionEdit
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
AnswerEdit
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