I have this code. It cycles thru and changes a value, then prints, and repeats. Issue is, my pdf is only of the last cycle value, its not adding each change as a separate sheet in my pdf.
Private Sub CommandButton1_Click()
For x = 1 To 100 'increase the 100 to a larger number if you ever have more than 100 sheets
If Sheets("Sheet2").Range("T" & x).Value = "" Then Exit Sub
Sheets("Sheet2").Range("F4").Value = Sheets("Sheet2").Range("T" & x).Value
Sheets("Sheet2").Range("F3").Value = Sheets("Sheet2").Range("U" & x).Value
'For Each ws In ActiveWorkbook.Worksheets
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF
Next
End Sub
Tried the code, expected a pdf with 20 sheets, but only got 1, the last value of my range.
This works for what I want.
Private Sub CommandButton1_Click()
For x = 1 To 100 'increase the 100 to a larger number if you ever have more than 100 sheets
If Sheets("Sheet2").Range("T" & x).Value = "" Then Exit Sub
Sheets("Sheet2").Range("F4").Value = Sheets("Sheet2").Range("T" & x).Value
Sheets("Sheet2").Range("F3").Value = Sheets("Sheet2").Range("U" & x).Value
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\test" & x & ".pdf"
Next
End Sub
Related
I have an excel document that runs a VBA script that I use user forms to input data. The script works fine, except for the grouping. There are 2 groups. The first is at the Customer Name, which works fine. The second is at the Effort Name, which does not. It groups the effort, but when grouped it still displays the last row. The developer I hired to write the script said that this error appears to be a bug in Excel or for some reason by design when two groups have the same last row.
Does anyone have a solution?
Images show the macros script and grouping Image of marcos
Image of grouping
Below is the VBA script that was written for creating the effort via user form.
Private Sub ButtonAddEffort_Click()
Dim c As Object
Dim sht As Worksheet
Dim foundrow As Long
Dim blassign As Boolean
Dim x As Long
Dim rowstart As Long
Dim rowend As Long
Dim i As Long
Dim rowstarteffort As Long
If IsNull(Me.txtProjectNumberLocate) Or Me.txtProjectNumberLocate = "" Then
MsgBox "Please enter a project number."
Me.txtProjectNumberLocate.SetFocus
Exit Sub
End If
If IsNull(Me.txtEffortName) Or Me.txtEffortName = "" Then
MsgBox "Please enter an effort name."
Me.txtEffortName.SetFocus
Exit Sub
End If
If Not IsNull(Me.txtStartDate) And Me.txtStartDate <> "" Then
If Not IsDate(Me.txtStartDate) Then
MsgBox "Please enter a valid start date in 'mm/dd/yyyy' format."
Me.txtStartDate.SetFocus
Exit Sub
End If
End If
If Not IsNull(Me.txtFinishDate) And Me.txtFinishDate <> "" Then
If Not IsDate(Me.txtFinishDate) Then
MsgBox "Please enter a valid finish date in 'mm/dd/yyyy' format."
Me.txtFinishDate.SetFocus
Exit Sub
End If
End If
Set sht = Sheets("Sheet1")
Set c = sht.Range("F:F").Find(what:=Me.txtProjectNumberLocate, after:=sht.Cells(1, 6), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False)
If Not c Is Nothing Then
foundrow = c.Row
rowstart = foundrow
rowstarteffort = foundrow
Else
foundrow = 0
End If
If foundrow = 0 Then
MsgBox "Could not find project # " & Me.txtProjectNumberLocate
Exit Sub
End If
''any efforts exist1
Set c = sht.Range("A:A").Find(what:="*", after:=sht.Cells(foundrow, 1), LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If Not c Is Nothing Then
foundrownext = c.Row
Else
foundrownext = 0
End If
If foundrownext > foundrow Then
foundrow = foundrownext - 1
End If
'check work order format
For x = 1 To 8
If Not IsNull(Me("txtworkorder" & x)) And Me("Txtworkorder" & x) <> "" Then
If Me("CheckBox" & x) = True Then
If Len(Me("txtWorkOrder" & x)) <> 8 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If InStr(1, Me("txtWorkOrder" & x), "-") = 0 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If Mid(Me("txtworkorder" & x), 5, 1) <> "-" Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If InStr(1, Left(Me("txtWorkOrder" & x), 4), "-") <> 0 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If InStr(1, Right(Me("txtWorkOrder" & x), 3), "-") <> 0 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
End If
End If
Next x
i = 0
If foundrownext > 1 Then
sht.Rows(rowstart + 1 & ":" & foundrownext - 1).Select
On Error Resume Next
Selection.Rows.Ungroup
On Error GoTo 0
End If
blassign = False
For x = 8 To 1 Step -1
If Me("CheckBox" & x) = True Then
blassign = True
End If
Next x
If blassign = False Then
sht.Range(foundrow + 1 & ":" & foundrow + 1).EntireRow.Insert shift:=xlDown
sht.Range("B" & foundrow + 1) = Me.txtEffortName
sht.Range("B" & foundrow + 1).Font.Color = 13998939
sht.Range("B" & foundrow + 1).Font.Underline = True
sht.Range("I" & foundrow + 1) = Me.txtStartDate
sht.Range("J" & foundrow + 1) = Me.txtFinishDate
i = 1
Else
sht.Range(foundrow + 1 & ":" & foundrow + 1).EntireRow.Insert shift:=xlDown
sht.Range("B" & foundrow + 1) = Me.txtEffortName
sht.Range("B" & foundrow + 1).Font.Color = 13998939
sht.Range("B" & foundrow + 1).Font.Underline = True
sht.Range("I" & foundrow + 1) = Me.txtStartDate
sht.Range("J" & foundrow + 1) = Me.txtFinishDate
For x = 8 To 1 Step -1
If Me("CheckBox" & x) = True Then
sht.Range(foundrow + 2 & ":" & foundrow + 2).EntireRow.Insert shift:=xlDown
sht.Range("F" & foundrow + 2) = Me("txtWorkOrder" & x)
sht.Range("G" & foundrow + 2) = Me("cmbAssign" & x)
i = i + 1
End If
Next x
End If
''group new efforts
If foundrownext <= 1 Then
foundrownext = rowstart + 1
End If
sht.Rows(foundrow + 2 & ":" & foundrownext + i).Select
Selection.Rows.Group
''ungroup and group old project data
rowend = foundrownext + i - 1
sht.Rows(rowstart + 1 & ":" & rowend).Select
Selection.Rows.Group
''
MsgBox "Done!"
End Sub
Private Sub ButtonClose_Click()
Unload Me
End Sub
Private Sub ComboBox1_Change()
End Sub
Private Sub ComboBox2_Change()
End Sub
Private Sub ComboBox3_Change()
End Sub
Private Sub ComboBox4_Change()
End Sub
Private Sub TextBox9_Change()
End Sub
Private Sub UserForm_Click()
End Sub
Outline (group) in Excel requires a summary row, that depending on the settings you have in your computer, should be placed below (default) or above each outline level.
Your situation
What's happening in your spreadsheet is that you currently have the default settings, i.e. summary row should be below the current outline level. And you're grouping the rows 9,10 and 13.
My guess here is that the developer tried to group effort 1 and effort 2 and it didn't work, because to group effort 2 without leaving an additional row would just look like this:
Note: See the 4 dots on the right of rows 13 to 16
The Excel solution
In this case, you need to toggle the settings so the summary rows are above the detail
How to adjust the settings
Outline settings:
Current configuration:
Adjusted configuration
This would allow to have the summary row above details like this:
And when collapsed:
The VBA solution
Now, about the VBA code you have, although it can certainly be improved, I understand it accomplishes your requirements.
I suggest to specially check these two blocks:
Block # 1:
''group new efforts
If foundrownext <= 1 Then
foundrownext = rowstart + 1
End If
sht.Rows(foundrow + 2 & ":" & foundrownext + i).Select
Selection.Rows.Group
Block #2
''ungroup and group old project data
rowend = foundrownext + i - 1
sht.Rows(rowstart + 1 & ":" & rowend).Select
Selection.Rows.Group
I'd suggest the developer to read this article on how and why to avoid select in Excel VBA.
Please let me know if the solution works and remember to mark the answer (tick the check mark at the left) if it does.
This is my code but I have a problem saving a file.
Private o As Integer
Public Sub Procedure1()
o = 1
End Sub
Sub dural()
Location = Sheets("uitleg").Range("A2").Value
Totallocation = Location & "\"
Debug.Print (Totallocation)
checkNum = Sheets("FunBelgium").Range("A1").Value
Debug.Print (checkNum)
lRow = Range("A65536").End(xlUp).Row 'finds last row, assumes contiguous data
j = 1 'first row for your output
For i = 1 To lRow
If Range("A" & i).Value = checkNum Then
Sheets("Output").Range("A" & j & ":N" & j).Value = Sheets("FunBelgium").Range("A" & i & ":N" & i).Value
Rows([i]).EntireRow.Delete
j = j + 1 'advances output row counter if checkNum is found
End If
Next
o = o + 1
Application.ScreenUpdating = True
Sheets("Export").Activate
ActiveSheet.Copy
Thisfile = ActiveSheet.Range("J2").Value
With ActiveSheet.UsedRange
.Copy
.PasteSpecial xlValues
.PasteSpecial xlFormats
End With
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=Totallocation & Thisfile, FileFormat:=xlCSV, CreateBackup:=True
'ActiveSheet.SaveAs Filename:="C:\Users\sgouman\Downloads\Bernd\" & Thisfile & ".csv"
Application.ScreenUpdating = True
ActiveWorkbook.Close
Sheets("FunBelgium").Activate
If Cells(1, 1) = "" Then
Sheets("Output").Cells.ClearContents
Exit Sub
Else:
Debug.Print ("niet leeg")
Sheets("Output").Cells.ClearContents
j = 0
Call dural
End If
End Sub
So the debug for totallocation is this:
C:\Users\sgouman\Downloads\Bernd\
But I get an 1004 error. If I just manually copy in that file location in the activeworkbook.saveas it works fine.
I believe this is the issue:
Totallocation = Location & "\"
Please replace by this:
Totallocation = Location & "\\"
Reason: the "\" character is a special character, giving another meaning to the next one (e.g. "\n" is newline, "\t" is tab character, ...).
I tried on my PC and there everything is working fine, please debug your VBA code to the "Save" line, and in the immediate window, launch following commands and let us know the results:
?totalLocation
?ThisFile
?totalLocation & Thisfile
This should show you what the filenames look like.
By the way, are you sure your directory is not read-only? Are you even sure that this is the line, causing the issue?
Sub NewRefesh()
If Not Range("X2") = "COMPLETE" Or Range("X2") = "CANCELLED" Then
Range("X2").Select
ActiveCell.FormulaR1C1 = "=GetOrderStatus(RC[1])"
End If
End Sub
The above code does for only X2 but i want do it till X52.
(Ex: Next check in X3 = COMPLETE" Or Range("X3") = "CANCELLED" Then
Range("X3").Select
ActiveCell.FormulaR1C1 = "=GetOrderStatus(RC[1])"and do the action, next X4 and so on
I think in your post you meant your criteria to be :
Not Range("X2") = "COMPLETE" >> can be replaced also with Range("X2") <> "COMPLETE"
Not Range("X2") = "CANCELLED" >> can be replaced also with Range("X2") <> "CANCELLED"
Note: it's better to stay away from Select and ActiveCell, instead use referenced Ranges. In your code you code directly use Range("X" & i).FormulaR1C1
Code
Option Explicit
Sub NewRefesh()
Dim i As Long
' simple For loop, you can modify to find last row with data instead of 52
For i = 2 To 52
If (Not Range("X" & i).Value = "COMPLETE") And (Not Range("X" & i).Value = "CANCELLED") Then
Range("X" & i).FormulaR1C1 = "=GetOrderStatus(RC[1])"
End If
Next i
End Sub
use row/col numbering
x is Column number 24
for i = 2 to 52
If Not cells(i,24) = "COMPLETE" Or cells(i,24) = "CANCELLED" Then
Range(i,24).Select
Whatever you want done.........
End If
Next i
I'm trying to use .clearcontents on range that is referenced by with some .offset, and I'm having trouble
I know that this works
Sub clear1_1()
Workbooks("xyz").Sheets("abc").range("A2:A3").ClearContents
End Sub
but if I try this it does not
Sub clear2()
Dim region As range
Set region = range("S509:AD618")
Workbooks("xyz").Worksheets("abc").range(region).ClearContents
end sub
I do understand from other postings, that it has something to do with object defyining, but I have no idea where I do mistake, what I need to write.
Final macro is run from one workbook, and is supposed to .clearcontents in other not activated workbook.
My code looks like this
sub Macro()
..... ton of code
Dim filename as string
dim sheetname as string
dim address3, address4 as string
filename = "xyz"
sheetname = "abc" ' both variables that are loaded in other part
address3 and address4 loaded in other part
'here is where i get the error
sheets(sheetname).Range(Range(address3).Offset(0, 12).Address & ":" & Range(address4).Offset(-1, 23)).ClearContents
end sub
I can probably bypass it with .value=""
But I'm looking to learn. Thank you for any response in advance.
EDIT 1
Hi Scott, doesn't make it. Posting bigger part of my code
If mapanchorsuccess = True And map1success = True And map2success = True Then
If Workbooks(Filename).Sheets(startws).Range(address1).Offset(10, 13).HasFormula = True Then
With Workbooks(wbm).Sheets("Report") 'report
.Range("A" & reportrow).Value = runnumber
.Range("B" & reportrow).Value = Filename
.Range("C" & reportrow).Value = Workbooks(Filename).Sheets(startws).Name
.Hyperlinks.Add anchor:=.Range("D" & reportrow), Address:=FilePath & Filename, SubAddress:=Workbooks(Filename).Sheets(startws).Name & "!A1"
.Range("E" & reportrow).Value = "Error"
.Range("F" & reportrow).Value = "rolling probably done already in this sheet"
reportrow = reportrow + 1
End With
Else
With Workbooks(Filename).Sheets(startws)
.Range(Range(address1).Offset(0, 12).Address & ":" & Range(address2).Offset(0, 14).Address).Copy _
Range(Range(address1).Address & ":" & Range(address2).Offset(0, 2).Address)
Application.CutCopyMode = False
.Range(Range(address1).Offset(0, 16).Address & ":" & Range(address2).Offset(0, 16).Address).Copy _
Range(Range(address1).Offset(0, 3).Address & ":" & Range(address2).Offset(0, 23).Address)
Application.CutCopyMode = False
With Workbooks(wbm).Sheets("Report") 'report
.Range("A" & reportrow).Value = runnumber
.Range("B" & reportrow).Value = Filename
.Range("C" & reportrow).Value = Workbooks(Filename).Sheets(startws).Name
.Hyperlinks.Add anchor:=.Range("D" & reportrow), Address:=FilePath & Filename, SubAddress:=Workbooks(Filename).Sheets(startws).Name & "!A1"
.Range("E" & reportrow).Value = "Completed"
.Range("F" & reportrow).Value = "region1 rolled forward"
reportrow = reportrow + 1
End With
.Range(Range(address3).Offset(0, 12).Address & ":" & Range(address4).Offset(-1, 23).Address).Copy _
Range(Range(address3).Address & ":" & Range(address4).Offset(-1, 11).Address)
'///// here the error 1004 occurs
.Range(Range(address3).Offset(0, 12).Address & ":" & Range(address4).Offset(-1, 23).address).clearcontent
End With
End If
End If
The workbook and sheet need to be set with the variable.
Then when using it since it is a range itself just refer to it.
Sub clear2()
Dim region As range
Set region = Workbooks("xyz").Worksheets("abc")range("S509:AD618")
region.ClearContents
end sub
As to your next code; that is a different problem. The ranges inside the () need to allocated to the correct sheet parentage or it will use the active sheet.
The easiest is with a With block:
With sheets(sheetname)
.Range(.Range(address3).Offset(0, 12), .Range(address4).Offset(-1, 23)).ClearContents
End With
I had this same issue, but it turned out to be very simple. I had a row of cells merged together between columns E and F, so when I used this command I had to set the ClearContents from the top corner of my E column to the bottom row of my F column.
What did not work:
Range("E1:E10").Clear Contents
What did work:
Range("E1:F10").ClearContents
I can't believe such a simple thing left me so thwarted.
I'm trying to write an if function into a save button on a user-form so that if the data entered into the user-form is already on sheet 2 then it only gets written to sheet 1. But if it does not exist on sheet 2 then the data from the user-form gets written to both sheet 1 and sheet 2. This is because I want the data on sheet 2 to act like a sort of database and obviously do not want duplicates. I've made the write procedures into two separate modules (I figured this would make it easier to differentiate). Here is my code (Be gentle I'm still learning)
Sub writetosheet1()
Dim i As Integer
i = 1
While ThisWorkbook.Worksheets("Sheet1").Range("A" & i).Value <> ""
i = i + 1
Wend
ThisWorkbook.Worksheets("Sheet1").Range("a" & i).Value = UserForm1.txt1.Value
ThisWorkbook.Worksheets("Sheet1").Range("b" & i).Value = UserForm1.txt2.Value
ThisWorkbook.Worksheets("Sheet1").Range("c" & i).Value = UserForm1.txt3.Value
ThisWorkbook.Worksheets("Sheet1").Range("d" & i).Value = UserForm1.txt4.Value
ThisWorkbook.Worksheets("Sheet1").Range("e" & i).Value = UserForm1.txt5.Value
End Sub
Sub writetosheet2()
Dim i As Integer
i = 1
While ThisWorkbook.Worksheets("Sheet1").Range("A" & i).Value <> ""
i = i + 1
Wend
ThisWorkbook.Worksheets("Sheet2").Range("a" & i).Value = UserForm1.txt1.Value
ThisWorkbook.Worksheets("Sheet2").Range("b" & i).Value = UserForm1.txt2.Value
ThisWorkbook.Worksheets("Sheet2").Range("c" & i).Value = UserForm1.txt4.Value
ThisWorkbook.Worksheets("Sheet2").Range("d" & i).Value = UserForm1.txt5.Value
End Sub
Private Sub CMDSAVE_Click()
Dim id As Long
id = txt1.Value
If id <> Sheets("Sheet2").Range("a:a").Value Then
Call writetosheet1
Call writetosheet2
Else
Call writetosheet1
End If
End Sub
Any help on this would be fantastic! Thanks.
I think that you can not compare one single value with whole range like this:
If id <> Sheets("Sheet2").Range("a:a").Value Then
You need to go trough all cells in that range separately.
If Application.CountIf(Sheet2.Range("A:A"), id) > 0 then
'write only to sheet1
else
'write to both sheets
end if