I have some code to pdf and save my file to a folder on my computer. I've tested in the past and had no problem. However, after making some minor changes i am getting run time error 1004. Any ideas on why this is? Very frustrating. Thank you.
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim i As Long
Dim ws As Worksheet
Dim FileName As String
Set ws = Sheets("Multi")
Set wsJob = Sheets("Job")
FileName = ws.Range("B2")
LastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
For i = 8 To LastRow
wsJob.Activate
wsJob.Range("AZ1").Value = ws.Range("B" & i)
wsJob.Range("AZ2").Value = ws.Range("C" & i)
wsJob.Range("AZ3").Value = ws.Range("D" & i)
wsJob.Range("AZ4").Value = ws.Range("E" & i)
wsJob.Range("AZ5").Value = ws.Range("F" & i)
wsJob.Range("AZ6").Value = ws.Range("G" & i)
wsJob.ComboBox1.Visible = False
wsJob.ComboBox2.Visible = False
wsJob.ComboBox3.Visible = False
wsJob.ComboBox4.Visible = False
wsJob.ComboBox5.Visible = False
wsJob.ComboBox6.Visible = False
wsJob.CommandButton1.Visible = False
wsJob.Rows("4:13").EntireRow.Hidden = True
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=ws.Range("B2") & "TCC Analysis - " & ws.Range("B" & i) & " - " & ws.Range("C" & i) & " - " & ws.Range("D" & i) & " - " & ws.Range("E" & i) & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
Next i
wsJob.ComboBox1.Visible = True
wsJob.ComboBox2.Visible = True
wsJob.ComboBox3.Visible = True
wsJob.ComboBox4.Visible = True
wsJob.ComboBox5.Visible = True
wsJob.ComboBox6.Visible = True
wsJob.CommandButton1.Visible = True
wsJob.Rows("4:13").EntireRow.Hidden = False
ws.Activate
Application.ScreenUpdating = True
End Sub
Replace this line;
FileName:=ws.Range("B2") & "TCC Analysis - " & ws.Range("B" & i) & " - " & ws.Range("C" & i) & " - " & ws.Range("D" & i) & " - " & ws.Range("E" & i) & ".pdf"
with this;
FileName:=ws.Range("B2").value & "TCC Analysis - " & ws.Range("B" & i).value & " - " & ws.Range("C" & i).value & " - " & ws.Range("D" & i).value & " - " & ws.Range("E" & i).value & ".pdf"
Replace;
wsJob.Range("AZ1").Value = ws.Range("B" & i)
wsJob.Range("AZ2").Value = ws.Range("C" & i)
wsJob.Range("AZ3").Value = ws.Range("D" & i)
wsJob.Range("AZ4").Value = ws.Range("E" & i)
wsJob.Range("AZ5").Value = ws.Range("F" & i)
wsJob.Range("AZ6").Value = ws.Range("G" & i)
with this;
wsJob.Range("AZ1").Value = ws.Range("B" & i).Value
wsJob.Range("AZ2").Value = ws.Range("C" & i).Value
wsJob.Range("AZ3").Value = ws.Range("D" & i).Value
wsJob.Range("AZ4").Value = ws.Range("E" & i).Value
wsJob.Range("AZ5").Value = ws.Range("F" & i).Value
wsJob.Range("AZ6").Value = ws.Range("G" & i).Value
Replace
FileName = Sheets("Multi").Range("B2")
with this
FileName = Sheets("Multi").Range("B2").value
Change FileName decleration with different string because FileName is also using in the ActiveSheet.ExportAsFixedFormat line...
Related
I have a userform with 5 checkbox buttons for 5 pdf versions.
Well, when the user calls the userform, then the userform initializes 5 checkbox buttons to select one of them. At the moment, the code is very static and not so good.
Here the example:
If rs.EOF = False Then
Do Until rs.EOF Or i = 5
Select Case i
Case Is = 0
frmOne.Version5.Visible = True
frmOne.Version5.Caption = rs!versNo & "#" & rs!versFrom
frmOne.Version5.tag = rs!versNo & "_" & rs!FiD & ".pdf"
Case Is = 1
frmOne.Version4.Visible = True
frmOne.Version4.Caption = rs!versNo & "#" & rs!versFrom
frmOne.Version4.tag = rs!versNo & "_" & rs!FiD & ".pdf"
Case Is = 2
frmOne.Version3.Visible = True
frmOne.Version3.Caption = rs!versNo & "#" & rs!versFrom
frmOne.Version3.tag = rs!versNo & "_" & rs!FiD & ".pdf"
Case Is = 3
frmOne.Version2.Visible = True
frmOne.Version2.Caption = rs!versNo & "#" & rs!versFrom
frmOne.Version2.tag = rs!versNo & "_" & rs!FiD & ".pdf"
Case Is = 4
frmOne.Version1.Visible = True
frmOne.Version1.Caption = rs!versNo & "#" & rs!versFrom
frmOne.Version1.tag = rs!versNo & "_" & rs!FiD & ".pdf"
End Select
i = i + 1
rs.MoveNext
Loop
End If
To much code I think. So my intention was to define it like the example below, but this doesn't work:
If rs.EOF = False Then
For i = 1 To 5
With frmOne
.Version & i &.Visible = True
.Version & i &.Caption = rs!versNo & "#" & rs!versFrom
.Version & i &.tag = rs!versNo & "_" & rs!FiD & ".pdf"
End With
rs.MoveNext
Next i
End If
Do have anyone an idea how could I fix that?
You can refer to the Controls collection using the name:
If rs.EOF = False Then
For i = 1 To 5
With frmOne.Controls("Version" & i)
.Visible = True
.Caption = rs!versNo & "#" & rs!versFrom
.tag = rs!versNo & "_" & rs!FiD & ".pdf"
End With
rs.MoveNext
Next i
End If
To actually add the controls at runtime too:
Do While not rs.EOF
i = i + 1
With frmOne.Controls.Add("Forms.CheckBox.1", "Version" & i, True)
.Caption = rs!versNo & "#" & rs!versFrom
.tag = rs!versNo & "_" & rs!FiD & ".pdf"
End With
rs.MoveNext
Loop
go like follows:
If rs.EOF = False Then
For i = 1 To 5
With frmOne.Controls("Version" & i) '<~~ use Controls collection of Userform object
.Visible = True
.Caption = rs!versNo & "#" & rs!versFrom
.Tag = rs!versNo & "_" & rs!FiD & ".pdf"
End With
rs.MoveNext
Next i
End If
I have the code below that updates data on the "Audit Sheet" with specific data from the "Master" sheet, prints the "Audit" sheet and loops until the last row is empty. It works great for a small amount of data, but I have another project that will have over 1800 rows of data. I don't want to clog up the printer with 1800 pages all at once.
What I want is to be able to have a box pop up and specify the beginning row and ending row. I have done this before, but I have forgotten over the years of how I originally wrote the code. Any help is appreciated.
Sub testLoopPaste()
Dim i As Long
Dim LastRow As Long
Dim wb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("Master")
Set sht2 = wb.Sheets("Audit Sheet")
Application.ScreenUpdating = False
'Find the last row (in column A) with data.
LastRow = sht1.Range("A:A").Find("*", searchdirection:=xlPrevious).Row
'This is the beginning of the loop
For i = 2 To LastRow
'First activity
sht2.Range("B1" & ii) = sht1.Range("B" & i).Value
sht2.Range("B2" & ii) = sht1.Range("A" & i).Value
sht2.Range("B3" & ii) = sht1.Range("N" & i).Value
sht2.Range("H1" & ii) = sht1.Range("C" & i).Value
sht2.Range("H2" & ii) = sht1.Range("I" & i).Value
sht2.Range("H3" & ii) = sht1.Range("F" & i).Value
sht2.Range("K1" & ii) = sht1.Range("D" & i).Value
sht2.PrintOut
Next i
Application.ScreenUpdating = True
End Sub
You want to loop over a range object in a manner similar to
dim rngobj, userinputstart, userinputend as variant
set rngobj = Range(Range(userinputstart),Range(userinputend))
For each therow in rngobj
'do stuff here
Next
Depending on how you grab user input you're going to have to fiddle with that part.
Thank you to all who posted. I finally figured out what worked best. Here is my finished code and it works perfectly.
Sub testLoopPaste()
Dim i As Long
Dim LastRow As Long
Dim wb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("Master")
Set sht2 = wb.Sheets("Audit Sheet")
Application.ScreenUpdating = False
'Find the last row of data
LastRow = InputBox("Enter the last row of data", "End Row")
'This is the beginning of the loop
For i = InputBox("Enter the first row of data", "Start Row") To LastRow
'First activity
sht2.Range("B2" & ii) = sht1.Range("B" & i).Value
sht2.Range("B4" & ii) = sht1.Range("C" & i).Value
sht2.Range("B6" & ii) = sht1.Range("D" & i).Value
sht2.Range("B8" & ii) = sht1.Range("L" & i).Value
sht2.Range("B10" & ii) = sht1.Range("M" & i).Value
sht2.Range("B12" & ii) = sht1.Range("N" & i).Value
sht2.Range("B14" & ii) = sht1.Range("Q" & i).Value
sht2.Range("B16" & ii) = sht1.Range("R" & i).Value
sht2.Range("B18" & ii) = sht1.Range("AO" & i).Value
sht2.Range("D2" & ii) = sht1.Range("J" & i).Value
sht2.Range("D4" & ii) = sht1.Range("K" & i).Value
sht2.Range("D6" & ii) = sht1.Range("O" & i).Value
sht2.Range("D8" & ii) = sht1.Range("A" & i).Value
sht2.Range("D10" & ii) = sht1.Range("AO" & i).Value
sht2.Range("D12" & ii) = sht1.Range("T" & i).Value
sht2.Range("D14" & ii) = sht1.Range("U" & i).Value
sht2.Range("D16" & ii) = sht1.Range("V" & i).Value
sht2.Range("D18" & ii) = sht1.Range("W" & i).Value
sht2.Range("D20" & ii) = sht1.Range("X" & i).Value
sht2.Range("D22" & ii) = sht1.Range("Y" & i).Value
sht2.Range("D24" & ii) = sht1.Range("Z" & i).Value
sht2.Range("D26" & ii) = sht1.Range("AA" & i).Value
sht2.Range("D28" & ii) = sht1.Range("AB" & i).Value
sht2.Range("D35" & ii) = sht1.Range("AT" & i).Value
sht2.Range("D37" & ii) = sht1.Range("AV" & i).Value
sht2.Range("D39" & ii) = sht1.Range("AX" & i).Value
sht2.Range("D41" & ii) = sht1.Range("AZ" & i).Value
sht2.Range("D43" & ii) = sht1.Range("BB" & i).Value
sht2.Range("D45" & ii) = sht1.Range("BD" & i).Value
sht2.Range("D47" & ii) = sht1.Range("BF" & i).Value
sht2.Range("D49" & ii) = sht1.Range("BH" & i).Value
sht2.Range("D51" & ii) = sht1.Range("BJ" & i).Value
sht2.Range("D53" & ii) = sht1.Range("BL" & i).Value
sht2.Range("D55" & ii) = sht1.Range("BN" & i).Value
sht2.Range("I2" & ii) = sht1.Range("F" & i).Value
sht2.Range("I4" & ii) = sht1.Range("G" & i).Value
sht2.Range("I6" & ii) = sht1.Range("S" & i).Value
sht2.Range("I8" & ii) = sht1.Range("AM" & i).Value
sht2.Range("I10" & ii) = sht1.Range("AN" & i).Value
sht2.Range("H12" & ii) = sht1.Range("AD" & i).Value
sht2.Range("H14" & ii) = sht1.Range("AE" & i).Value
sht2.Range("H16" & ii) = sht1.Range("AF" & i).Value
sht2.Range("H18" & ii) = sht1.Range("AG" & i).Value
sht2.Range("H20" & ii) = sht1.Range("AH" & i).Value
sht2.Range("H22" & ii) = sht1.Range("AQ" & i).Value
sht2.Range("H24" & ii) = sht1.Range("AI" & i).Value
sht2.Range("H26" & ii) = sht1.Range("AJ" & i).Value
sht2.Range("H28" & ii) = sht1.Range("AK" & i).Value
sht2.Range("H30" & ii) = sht1.Range("AL" & i).Value
sht2.Range("H35" & ii) = sht1.Range("AU" & i).Value
sht2.Range("H37" & ii) = sht1.Range("AW" & i).Value
sht2.Range("H39" & ii) = sht1.Range("AY" & i).Value
sht2.Range("H41" & ii) = sht1.Range("BA" & i).Value
sht2.Range("H43" & ii) = sht1.Range("BC" & i).Value
sht2.Range("H45" & ii) = sht1.Range("BE" & i).Value
sht2.Range("H47" & ii) = sht1.Range("BG" & i).Value
sht2.Range("H49" & ii) = sht1.Range("BI" & i).Value
sht2.Range("H51" & ii) = sht1.Range("BK" & i).Value
sht2.Range("H53" & ii) = sht1.Range("BM" & i).Value
sht2.Range("H55" & ii) = sht1.Range("BO" & i).Value
sht2.PrintOut
Next i
Application.ScreenUpdating = True
End Sub
hopefully someone would be kind enough to point out why this isn't working. Basically via vba a new line is inserted # the last row of a table (Row41), this pushes the last line down (creating a gap within the data) then the last line values are transferred up one row so the blank row is at the bottom.
Now the process works fine except for two of the cell values change randomly, below are the before and after
Before:
Cell(41,B) = 03/10/14
Cell(41,C) = 12345
Cell(41,E) = 3.00
Cell(41,F) = DD
After:
Cell(41,B) = 03/10/14
Cell(41,C) = 12345
Cell(41,E) = 41915
Cell(41,F) = 41915
I've double checked the set ranges and they are as they should be, any ideas? Oh for the code the Specific_Tbl variable is 2
'[Capture table First/Last row number]
int_FirstRow = .Cells(4, "AC").Offset(0, Specific_Tbl)
int_LastRow = .Cells(6, "AC").Offset(0, Specific_Tbl)
'[Insert Blank Row]
.Range("A" & int_LastRow & ":Z" & int_LastRow).Insert shift:=xlDown
'[Set Cell Ranges]
Select Case Specific_Tbl
Case 1
'[Remerge Description]
.Range(.Cells(int_LastRow, "E"), .Cells(int_LastRow, "H")).MergeCells = True
Set rng_Tmp1 = .Range("B" & int_LastRow & ":C" & int_LastRow & ",E" & int_LastRow & ":J" & int_LastRow)
Set rng_Tmp2 = .Range("B" & int_LastRow + 1 & ":C" & int_LastRow + 1 & ",E" & int_LastRow + 1 & ":J" & int_LastRow + 1)
Case 2, 3
Set rng_Tmp1 = .Range("B" & int_LastRow & ":C" & int_LastRow & ",E" & int_LastRow & ":F" & int_LastRow)
Set rng_Tmp2 = .Range("B" & int_LastRow + 1 & ":C" & int_LastRow + 1 & ",E" & int_LastRow + 1 & ":F" & int_LastRow + 1)
End Select
'[Transfer values and clear]
rng_Tmp1.Value = rng_Tmp2.Value
rng_Tmp2.ClearContents
Unfortunately I never discovered why excel vba was unable to deal with the split range like I believed it would. A workaround was done by adding more range variables to deal with each side of the split range.
'[Capture table First/Last row number]
int_FirstRow = .Cells(4, "AC").Offset(0, Specific_Tbl)
int_LastRow = .Cells(6, "AC").Offset(0, Specific_Tbl)
'[Insert Blank Row]
.Range("A" & int_LastRow & ":Z" & int_LastRow).Insert shift:=xlDown
'[Set Cell Ranges]
Select Case Specific_Tbl
Case 1
'[Remerge Description]
.Range(.Cells(int_LastRow, "E"), .Cells(int_LastRow, "H")).MergeCells = True
Set rng_Tmp1 = .Range("B" & int_LastRow & ":C" & int_LastRow)
Set rng_Tmp2 = .Range("B" & int_LastRow + 1 & ":C" & int_LastRow + 1)
Set rng_Tmp3 = .Range("E" & int_LastRow & ":J" & int_LastRow)
Set rng_Tmp4 = .Range("E" & int_LastRow + 1 & ":J" & int_LastRow + 1)
Case 2, 3
Set rng_Tmp1 = .Range("B" & int_LastRow & ":C" & int_LastRow)
Set rng_Tmp2 = .Range("B" & int_LastRow + 1 & ":C" & int_LastRow + 1)
Set rng_Tmp3 = .Range("E" & int_LastRow & ":F" & int_LastRow)
Set rng_Tmp4 = .Range("E" & int_LastRow + 1 & ":F" & int_LastRow + 1)
End Select
'[Transfer values and clear]
rng_Tmp1.Value = rng_Tmp2.Value
rng_Tmp3.Value = rng_Tmp4.Value
rng_Tmp2.ClearContents
rng_Tmp4.ClearContents
The code below calculate an average between col E, colG and col I (like in the picture in column K)but something doesn't work how I need. My code doesn't take correctly column G. It takes in the loop 5,7,3,15,10 and not 5,5,7,3,3,3,15,15,10,10. It doesn't consider how many repetitive names are in column A. How to solve the problem? Anyone is able to help? thanks!
(look at the picture)
For f= 1 To ws.Range("F" & Rows.Count).End(xlUp).Row
nameF = ws.Range("F" & f).Value
For totRng = 1 To lastrowA
'if names from col A and col F coincide, then sum their numbers from col E
If nameF = ws.Range("A" & totRng).Value Then ws.Range("G" & f).Value =
ws.Range("G" & f).Value + ws.Range("E" & totRng).Value
On Error Resume Next
If nameF = ws.Range("A" & totRng).Value Then _
ws.Range("H" & f).Value = ((ws.Range("E" & f).Value / ws.Range("G" & f).Value)) * ws.Range("I" & f).Value
Next totRng
Next f
I should change this value: '/ ws.Range("G" & f).Value)'
Here a working piece of code
For f = 2 To ws.Range("F" & Rows.Count).End(xlUp).Row
nameF = ws.Range("F" & f).Value
For totRng = 2 To lastrowA
'if names from col A and col F coincide, then sum their numbers from col E
If nameF = ws.Range("A" & totRng).Value Then
ws.Range("G" & f).Value = ws.Range("G" & f).Value + ws.Range("E" & totRng).Value
End If
Next totRng
For totRng = 2 To lastrowA
'calculate the average
If nameF = ws.Range("A" & totRng).Value Then
Debug.Print nameF & " found on line " & totRng & " person we have is on line " & f & ". Formula is : ((" & ws.Range("E" & totRng).Value & "/" & ws.Range("G" & f).Value & ")*" & ws.Range("I" & totRng).Value & "=" & (((ws.Range("E" & totRng).Value / ws.Range("G" & f).Value)) * ws.Range("I" & totRng).Value)
ws.Range("H" & f).Value = ws.Range("H" & f).Value + (((ws.Range("E" & totRng).Value / ws.Range("G" & f).Value)) * ws.Range("I" & totRng).Value)
End If
Next totRng
Next f
I am trying to test on an "IF" statement with 5 criteria, the code works fine if I'm only testing with 3 criteria, but as soon as I add any extra it stops working. No errors, it just stops.
If Me.Count_Criteria_5.Value <> "Any" Then
For i = RowNum To RowNumEnd
If ws.Cells(i, CR1).Value = V_1 And ws.Cells(i, CR2).Value = V_2 And _
ws.Cells(i, CR3).Value = V_3 And ws.Cells(i, CR4).Value = V_4 And _
ws.Cells(i, CR5).Value = V_5 Then
ws.Range("A" & i & ":AM" & i).Copy
ps.Activate
'find first empty row in database
emR = ps.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
ps.Range("A" & emR & ":AM" & emR).PasteSpecial
End If
Next i
Exit Sub
End If ' End 5 Criteria Loop
Am I missing something?
Note: ws and ps are defined as worksheets
UPDATE
Based on the comments on this question, the problem appears to be the criteria being used. It's because of testing against checkboxes. Checkboxes when checked return the value of TRUE. But when testing with this code, it doesn't recognise that the "TRUE" on the worksheet is the same as the "TRUE" in the V_#
Anyone have any ideas?
Use this right before the evaluation.
Msgbox "CR1 = " & ws.Cells(i, CR1) & " V_1 = " & V_1 & vbCrLf & _
"CR2 = " & ws.Cells(i, CR2) & " V_2 = " & V_2 & vbCrLf & _
"CR3 = " & ws.Cells(i, CR3) & " V_3 = " & V_3 & vbCrLf & _
"CR4 = " & ws.Cells(i, CR4) & " V_4 = " & V_4 & vbCrLf & _
"CR5 = " & ws.Cells(i, CR5) & " V_5 = " & V_5 "
to simplify debugging greatly.
EDIT : Try this !
If ws.Cells(i, CR1).Value = V_1 And ws.Cells(i, CR2).Value = V_2 And _
ws.Cells(i, CR3).Value = V_3 And _
(ws.Cells(i, CR4).Value = V_4 or ws.Cells(i, CR4).Value = "TRUE") And _
(ws.Cells(i, CR5).Value = V_5 or ws.Cells(i, CR5).Value = "TRUE") Then