I was wondering if its possible to have a macro that populates a page and prints it then goes to the next one from the column and so on.
The number would go on Sheet2, C2 and name on C4. this is a template so it should delete empty and then refresh the next number and name from the list in sheet1.
The only thing is could it be set so I can select the starting cell or does it have to print all in the row at once? Say I only wanted to print 20 today then another 50 tomorrow can that be done....
Its a lot of manual typing at the moment so any help would be great.
I have an example below (names changed) that the column could have up to 500 names that need to be printed to place in each folder. Below put the number in correctly I just cant work out how to also include the name from cell D2 in sheet1
Sub PrintLoop()
Dim c As Range, LR As Long
Application.ScreenUpdating = False
LR = Sheets("sheet1").Range("C" & Rows.Count).End(xlUp).Row
For Each c In Sheets("sheet1").Range("C2:C" & LR)
Sheets("sheet2").Range("C2").Value = c.Value
Sheets("sheet2").PrintPreview
Next c
Application.ScreenUpdating = True
End Sub
Select just the rows you want to print before running...
Sub PrintLoop()
Dim rw As Range
Application.ScreenUpdating = False
For Each rw In Selection.Rows
With Sheets("sheet2")
.Range("C2").Value = rw.EntireRow.Cells(3).Value
.Range("C4").Value = rw.EntireRow.Cells(4).Value
.PrintPreview
'.PrintOut From:=1, To:=1, Copies:=1
End With
Next rw
Application.ScreenUpdating = True
End Sub
Related
I was wondering if anyone might be able to help me with this problem;
I have a large table. For all the rows in column F that meet a condition (must have a value of 89), I want to select the corresponding rows in columns A, H, and I. I then want to take these rows and export them as a csv file, and the file must be overwritten if it already exists.
For example, Let's say my table looks like;
F A B C H I
89 45 4 3 6 2
43 23 4 5 4 2
89 3 6 5 65 7
22 43 6 6 2 4
89 56 9 9 35 2
So as there are 3 rows in column F that meets the condition and the corresponding column A, H, and I rows have the values (45, 6, 2), (3, 65, 7) and (56, 35, 2) I want my exported file to look something like this;
**A H I**
45 6 2
3 65 7
56 35 2
I am having issues with 2 things:
being able to select only the specific cells for the SAME rows in the three wanted columns. Most of the help I found on the internet work only for choosing 1 specific cell, or entire columns. Given that I don't know which rows in column F will meet the condition, I cannot manually choose the corresponding cells in columns A, H, and I, as I don't know the row numbers.
My exported file won't act right; it either cannot overwrite (code1) or it keeps overwriting over and over and opens new workbooks when I run the code (code 2)
I have been trying back and forth for some time, and searched through the internet for anything that might help, but I cannot get it to work. As of now I have 2 different codes, that I've been trying to make work, but neither of them do.
The first code is:
Private Sub CommandButton1_Click()
Dim TransferExport As Integer
Dim u As Integer
Dim x As Integer
Dim y As Integer
Dim data As String
For i = 2 To 18288
If Sheets("Base").Cells(i, 6).Value = "89" Then
u = Sheets("Base").Cells(i, 1).Value
If Sheets("Base").Cells(i, 6).Value = "89" Then
x = Sheets("Base").Cells(i, 8).Value
If Sheets("Base").Cells(i, 6).Value = "89" Then
y = Sheets("Base").Cells(i, 9).Value
End If
End If
End If
TransferExport = FreeFile
data = data & Sheets("Base").Cells(1, 1) & u & " ; "
data = data & Sheets("Base").Cells(1, 8) & x & " ; "
data = data & Sheets("Base").Cells(1, 9) & y & " ; "
Open "C:\Users\bruger1\Documents\Uni\TransferExport.csv" For Append As
#TransferExport
Print #TransferExport, u, x, y
Close #TransferExport
Next
MsgBox "Your file has been exported"
End Sub
^This is my first code. Please note that I am aware that for my "If-Then" selections of u, x, and y, I am selecting the entire column which is of course not what I want, but I cannot find a way to make it select only the corresponding row. While it does run, it cannot run completely as there are too many rows (18288) and the rows that it does manage to pull out simply all say "0", nor does it pull out the top row in each column as I specified in the data strings (the top row is the column names). I tried to do like this;
Dim rw As Range
Set rw = Sheets("Base").Range("F:F")
For i = 2 To 18288
If rw = "89" Then
u = Sheets("Base").Cells(rw, 1).Value
But this wont work. The other problem with this code is, that it won't overwrite the file if it already exists and instead just refuses to run.
The second code that I've tried is;
Private Sub CommandButton1_Click()
Dim rng As Range
Dim cell As Range
Dim data As String
Set rng = Range("F2:F18288")
For Each cell In rng
If cell.Value = "89" Then
Sheets("Base").Cells(cell, "A").Select
Sheets("Base").Cells(cell, "H").Select
Sheets("Base").Cells(cell, "I").Select
End If
Selection.Copy
data = "C:\Users\bruger1\Documents\Uni\TransferExport.csv"
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=data, _
FileFormat:=xlCSV, CreateBackup:=False, local:=True
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next
MsgBox "Your file has been exported"
End Sub
I have several problems with this one; first, when I click the command button it will do different things for everytime I click? Sometimes it will continuously ask me if I want to overwrite the existing file, and also open a new document. Everytime I click yes it opens a new document and immediately asks me the same thing. If I click no or cancel it gives me a run-time error "1004". Sometimes it will export the file but also open a new workbook with a random value from my table which I did not try to pull out? Meanwhile the actual exported file "TransferExport" simply has single number "1" written in cell A1.
As said, I have been trying back and forth with any help I could find on the internet but nothing has worked so far. Any help would be greatly appreciated.
Something like this is what you're looking for:
Sub tgr()
'Declare variables
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsTemp As Worksheet
Dim sCSVPath As String
Dim sCSVName As String
Dim sSearchCol As String
Dim vCriteria As Variant
'Turn off these items to run code faster, prevent "screen flickering", and ignore warnings (such as if you want to override an existing file)
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
'Set variables
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Base") 'This is the sheet containing the original data
Set wsTemp = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
sCSVPath = Environ("UserProfile") & "\Documents\Uni\" 'This is the folder path where the CSV file will be stored (automatically gets logged in user's username)
sCSVName = "TransferExport.csv" 'Name of the CSV file
sSearchCol = "F" 'Column in the original data to search
vCriteria = 89 'Critiera to search for in the specified column
'Work with the specified column
With wsData.Range(wsData.Cells(1, sSearchCol), wsData.Cells(wsData.Rows.Count, sSearchCol).End(xlUp))
'Filter for the specified criteria
.AutoFilter 1, vCriteria
'Copy relevant columns (A, H, and I) to the temp worksheet as values only
Intersect(.EntireRow, .Parent.Range("A:A,H:I")).Copy
wsTemp.Range("A1").PasteSpecial xlPasteValues
'Remove the filter
.AutoFilter
End With
'Move the temp sheet to its own workbook and save it as a CSV file and close it
'Because we turned off item DisplayAlerts, this will automatically overwrite the file if it already exists
wsTemp.Move
ActiveWorkbook.SaveAs sCSVPath & sCSVName, xlCSV
ActiveWorkbook.Close False
'Turn items back on
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Try This, please read the comments and try to understand everything happening in the code, feel free to ask questions:
Private Sub CommandButton1_Click()
Dim data As String, lastRow As Long, i As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Set wk = ThisWorkbook
'New Workbook
Workbooks.Add
Set awk = ActiveWorkbook
'Copy all data to new Workbook
wk.Sheets("Base").Columns("A:F").Copy
awk.Worksheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Find the lastRow in this data based on Column F (6)
lastRow = awk.Worksheets(1).Cells(Excel.Rows.Count, 6).End(Excel.xlUp).Row
'Loop and Remove any Row where F is NOT "89"
For i = lastRow To 1 Step -1
If awk.Worksheets(1).Cells(i, 6).Value <> "89" Then
awk.Worksheets(1).Cells(i, 6).EntireRow.Delete
End If
Next
'Delete columns we dont want
awk.Worksheets(1).Columns("B:G").Delete Shift:=xlToLeft
'Save/Ovewrite It, Close it.
data = "C:\Users\bruger1\Documents\Uni\TransferExport.csv"
awk.SaveAs Filename:=data, FileFormat:=xlCSV, AccessMode:=xlExclusive, _
ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
Application.Calculation = xlCalculationAutomatic
awk.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Your file has been exported"
End Sub
I wrote a small VBA macro to compare two worksheets and put unique values onto a new 3rd worksheet.
The code works, but every time I use if excel goes "not responding" and after 30-45sec comes back and everything worked as it should.
Can I make this faster and get rid of the "not responding" issue? is it just my computer not being fast enough?
I start with about 2500-2700 rows in each sheet I'm comparing.
Sub FilterNew()
Dim LastRow, x As Long
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values
Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet
Sheets(1).Select
LastRow = Range("B1").End(xlDown).Row
Application.ScreenUpdating = False
For Each Cell In Range("B2:B" & LastRow)
x = 2 'This is for looking through rows of sheet2
Dim unique As Boolean: unique = True
Do
If Cell.Value = Sheets(2).Cells(x, "B").Value Then 'Test if cell matches any cell on Sheet2
unique = False 'If the cells match, then its not unique
Exit Do 'And no need to continue testing
End If
x = x + 1
Loop Until IsEmpty(Sheets(2).Cells(x, "B"))
If unique = True Then
Cell.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next
Application.ScreenUpdating = True
End Sub
This belongs in Code Review, but here is a link
http://www.excelitems.com/2010/12/optimize-vba-code-for-faster-macros.html
With your code your main issues are:
Selecting/Activating Sheets
Copy & pasting.
Fix those things and youll be set straight my friend :)
instead of a do...loop to find out duplicate, I would use range.find method:
set r = SHeets(2).range("b:b").find cell.value
if r is nothing then unique = true else unique = false
(quickly written and untested)
What about this (it's should help):
Sub FilterNew()
Dim Cel, Rng As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "New" 'Adds a new Sheet to store unique values
Sheets(1).Rows("1:1").Copy Sheets("New").Rows("1:1") 'Copies the header row to the new sheet
Set Rng = Sheet(1).Range("B2:B" & Sheet(1).Range("B1").End(xlDown).Row)
For Each Cel In Rng
If Cel.Value <> Sheet(2).Cells(Cel.Row, 2).Value Then Cel.EntireRow.Copy Sheets("New").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) ' The only issue I have with this is that this doesn't actually tell you if the value is unique, it just tells you ins not on the same rows of the first and second sheet - Is this alright with you?
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I have a formula that shows which rows in a specific column meet a set of criteria. When the formula is executed and applied to all rows, I run a loop to check which rows returned a value as a text, and then copy-pastes this cells to another worksheet:
Sub loop1()
Dim r As Range, c As Range
With Worksheets("Sheet1")
Set r = Range(.Range("AF2"), .Range("AF2").End(xlDown))
For Each c In r
If WorksheetFunction.IsText(c) Then
Range(.Cells(c.Row, "AF"), .Cells(c.Row, "AF")).Copy
Else
GoTo nextc
End If
With Worksheets("Sheet2")
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End With
nextc:
Next c
End With
Application.CutCopyMode = False
End Sub
What I want to do now is to run the formula for 631 different names, copy-paste every name as a headline and then run loop1. I cant figure out though how to make the for loop work inside the formula.
Sub loop2()
Dim i As Integer
For i = 2 To 632
Sheets("Sheet1").Select
Range("AC2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-3]=""district1"",(IF(RC[2]=R2C33 ,(IF(RC[-18]>=1,0,(IF(RC[-16]>=1,0,IF(RC[-14]>=1,0,IF(RC[-12]>=1,0,IF(RC[-10]>=1,1,IF(RC[-8]>=1,1,IF(RC[-6]>=1,1,0))))))))),0)),0)"
Range("AC2").Select
Selection.AutoFill Destination:=Range("AC2:AC20753")
Range("AC2:AC20753").Select
Range("AG2").Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
Selection.Font.Bold = True
Sheets("Sheet1").Select
Application.Run "'Customers.xlsb'!loop1"
Next i
End Sub
The cells that need to be changed for every loop are, R2C33 to something like RiC33 (which doesn't work) and the "headline" Range("AG2").Select to something like Range("AGi").Select.
Anyone who could help?
The following code will do the trick:
Sub loop2()
Dim i As Integer
For i = 2 To 632
Sheets("Sheet1").Range("AC2:AC20753").FormulaR1C1 = _
"=IF(RC[-3]=""district1"",(IF(RC[2]=R" & i & "C33 ,(IF(RC[-18]>=1,0,(IF(RC[-16]>=1,0,IF(RC[-14]>=1,0,IF(RC[-12]>=1,0,IF(RC[-10]>=1,1,IF(RC[-8]>=1,1,IF(RC[-6]>=1,1,0))))))))),0)),0)"
Sheets("Sheet1").Range("AG" & i).Copy Destination:=Sheets("Sheet2").Range("A1")
Sheets("Sheet2").Range("A1").Font.Bold = True
Application.Run "'Customers.xlsb'!loop1"
Next i
End Sub
In order to let i be used within your String formula you have to stop the String " use & i & and continue the String ".
I have also changed your code to prevent the use of .Select, which is a no no in VBA.
This way it fills in your Formula copy's and changes the Font without selecting anything or changing sheets.
As Jeep noted you do however need to change Sheets(""Sheet2").Range("A1") as I don't know which cell you want to paste into.
Your first sub procedure might be better like this.
Sub loop1()
Dim r As Range, c As Range
With Worksheets("Sheet1")
Set r = Range(.Range("AF2"), .Range("AF2").End(xlDown))
For Each c In r
If WorksheetFunction.IsText(c) Then
Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = _
.Cells(c.Row, "AF").Value2
End If
Next c
End With
End Sub
Direct value transfer is preferred over a Copy, Paste Special, Values.
In the second sub procedure, you don't have to do anything but remove the 2 from R2C33; e.g. RC33. In xlR1C1 formula construction a lone R simply means the row that the formula is on and you are starting at row 2. You can also put all of the formulas in at once. Once they are in you can looop through the G2:G632 cells.
Sub loop2()
Dim i As Integer
With Sheets("Sheet1")
.Range("AC2:AC20753").FormulaR1C1 = _
"=IF(OR(AND(RC[-3]=""district1"", RC[2]=R2C33, RC[-18]>=1), SUM(RC[-16], RC[-14], RC[-12])>=1), 0, IF(SUM(RC[-10], RC[-8], RC[-6])>=1, 1, 0))"
For i = 2 To 632
.Range("AG" & i).Copy _
Destination:=Sheets("Sheet2").Somewhere
Sheets("Sheet2").Somewhere.Font.Bold = True
Application.Run "'Customers.xlsb'!loop1"
Next i
Next i
End Sub
I also tightened up your formula by grouping some of the conditions that would result in zero together with OR and AND functions.
The only thing remaining would be defining the Destination:=Sheets("Sheet2").Somewhere I left hanging.
I have been creating a small project that will allow a user to import and export data from work worksheet to another. I will attach screenshots to try and explain what i am trying to achieve.
I have the import section of my program working without fault and i can import all jobs that are of colour "Red" from my second worksheet. However once the row has been changed to colour "Green" in worksheet 1 it will then be exported back to sheet 2 and in turn will change the once "Red" job to "Green" effecting no other rows in sheet 2.
I have tried to implement the code as best as i could however i keep getting errors when comparing the my unique cell in both ranges.
As of just now when i run the code it will copy over the value 10 times and paste over all data from row "A4" to row "A14"
Worksheet One
Worksheet Two
Sub Button3_Click()
'#Author - Jason Hughes(AlmightyThud)
'#Version - 1.0
'#Date - 0/03/2015
'#Description - To Export all Completed Jobs to the "Daily Work Orders" Spreadsheet
'Once exported it will scan for the unique job number in the list and override the existing values
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False
Application.EnableEvents = False
'Declare initial variables for this button'
Dim copyComplete As Boolean
copyComplete = False
Dim lR As Long
'----------------------------------'
'#When this code is uncommented it will delete all values in column A#'
Dim jobID As Range
Dim jobID2 As Range
Set jobID = Sheets("Daily Screen Update").Range("A4:A31")
Set jobID2 = Sheets("Daily Work Orders").Range("A4:A10000")
'----------------------------------'
'Activate the sheet you will be looping through'
ThisWorkbook.Sheets("Daily Screen Update").Activate
'Simple loop that will loop through all cells to check if the cell is green'
'If the cell is green then the loop will copy the cell, once copied the loop will check'
'the "Daily Work Orders" Sheet for a job ID with a similar ID and paste over it'
For Each greenjob In Range("A4:A31")
If greenjob.Cells.EntireRow.Interior.Color = RGB(146, 208, 80) Then
greenjob.Cells.EntireRow.Copy
For j = 4 To 31
For i = 4 To 10
If jobID.Cells(j, 1).Value = jobID2.Cells(i, 1).Value Then
Sheets("Daily Work Orders").Range("A" & j).PasteSpecial xlPasteAll
copyComplete = True
End If
Next i
Next j
End If
Next
'Make a check to ensure that the data has been copied
If copyComplete = True Then
MsgBox ("All completed jobs have been have been added to Daily Work Orders")
ElseIf copyComplete = False Then
MsgBox ("Nothing has been added to Daily Work Orders")
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.CutCopyMode = False
End Sub
You have three For loops:
For Each greenjob In Range("A4:A31")
For j = 4 To 31
For i = 4 To 10
Loop 1 goes through all of the rows on Worksheet One and identifies ones that need to be copied, so Loop 2 going through all of those rows again each time Loop 1 catches one doesn't make sense.
Instead, just use the Job Number from the row identified in Loop 1 and compare it to the Job Numbers on Worksheet 1 using Loop 3.
So, remove For j = 4 To 31 and Next j, and replace
If jobID.Cells(j, 1).Value = jobID2.Cells(i, 1).Value Then
with
If greenjob.Value = jobID2.Cells(i, 1).Value Then
since greenjob is, conveniently, the cell in column A that contains the job number.
I have a worksheet which has many terms in Column A.I want to search for two terms for example
term A and term B and copy all rows between the two terms and paste it into a new sheet.These two terms may repeat in the column. The problem which I am basically facing the following problem : whenever I run my code it also copies rows between term B and term A which is unnecessary. Following is the code i am using for two terms term A and term B.
For example my column A is
Institute
Event
Job
Computer
Laptop
Figures
Event
figures
format
computer
and many more terms
I want to copy all the rows between term A: Event and term B: Laptop and paste it into a new sheet. What my code is doing is it is copying the rows between all combinations of Event and computer. Even the rows between computer and event are copied(in this case Figure and laptop).
Sub OpenHTMLpage_SearchIt()
Dim Cell As Range, Keyword$, N%, SearchAgain As VbMsgBoxResult
Dim ass As Variant
Dim Cellev As Range, prakash$, P%, SearchAgaina As VbMsgBoxResult
Dim asa As Variant
StartSearch:
N = 1
Keyword = "Event"
If Keyword = Empty Then GoTo StartSearch
For Each Cell In Range("A1:A500")
If Cell Like "*" & Keyword & "*" Then
ass = Cell.Address
P = 1
prakash = "Computer"
If prakash = Empty Then GoTo StartSearch
For Each Cellev In Range("A1:A500")
If Cellev Like "*" & prakash & "*" Then
asa = Cellev.Address
Range(asa, ass).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
Range("B13").Select
ActiveSheet.Paste
Worksheets("sheet1").Select
P = P + 1
End If
Next Cellev
N = N + 1
End If
Next Cell
End Sub
Edit: code formatting.
The following is the code which is working for me.This copies everything in between Event and laptop and pastes it into a new sheet. Then again it searches for a second time and this time the search will start from the next row to the first search.I hope I am clear with this.
Sub Star123()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Startsheet").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("StartSheet").Range("a1:a" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "Event" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "Laptop"
endrow = rownum
rownum = rownum + 1
Worksheets("StartSheet").Range(startrow & ":" & endrow).Copy
Sheets("Result").Select
Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
Try this:
Sub DoEeeeeet(sheetName, termA, termB)
Dim foundA As Range, _
foundB As Range
Dim newSht As Worksheet
With Sheets(sheetName).Columns(1)
Set foundA = .Find(termA)
If Not foundA Is Nothing Then
Set foundB = .Find(termB, after:=foundA, searchdirection:=xlPrevious)
End If
End With
If foundA Is Nothing Or foundB Is Nothing Then
MsgBox "Couldn't find " & IIf(foundA Is Nothing, termA, termB)
Else
Range(foundA, foundB).Copy
Set newSht = Sheets.Add
newSht.Range("B13").PasteSpecial
End If
End Sub
You can call it as follows:
DoEeeeeet "Sheet1","Event","Laptop"
It'll find the first instance of "Event" and the last instance of "Laptop" on the sheet named "Sheet1" and copy all of that data to B13 and subsequent cells in a new sheet.
Is that what you want? Or do you want each of the subranges beginning with "Event" and ending with "Laptop"?