I am attempting to write a macro that:
Iterates over a list of employee IDs, identifies whether it needs a report generated or not then, filters a large dataset to include only that employee, grab several different columns, and paste them into a formatted sheet. It will then copy that sheet and save it into a file directory as a binary file.
The code works as expected sometimes, but other times, it seems to be pasting the all the data in a different row (it varies, but is usually between rows 8800 and 9200). I want it to paste in Row 2. The only clue that I have found to indicate the cause is that column S, where Gross Margin is stored, seems to have a couple hundred rows of data above where the table starts (only in some cases though). All data is still lining up in the correct rows.
Sub SplitFile()
Application.DisplayAlerts = False
Set wb = Application.ActiveWorkbook
Set pivots = wb.Sheets("Pivots")
Set repository = wb.Sheets("Repository")
Set listing = wb.Sheets("Customer Listing")
For Each rep In pivots.Range("A4:A" & pivots.Range("A3").End(xlDown).Row)
If rep.Offset(0, 1) <> "" Then
Debug.Print rep
lastRow = repository.Range("A1").End(xlDown).Row
repName = rep.Offset(0, 1).Value
repDistrict = rep.Offset(0, 2).Value
folderPath = pivots.Range("B1").Value & "\" & repDistrict
repository.Range("A1:AU" & lastRow).AutoFilter Field:=33, Criteria1:=rep
'EEID and Name
repository.Range("AG2:AH" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("A2")
'Source
repository.Range("F2:F" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("C2")
'Cust ID
repository.Range("H2:H" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("D2")
'Cust Name
repository.Range("K2:K" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("E2")
'Address Details
repository.Range("S2:U" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("F2")
'Predominant Trade, Active/Inactive, Start Date
repository.Range("W2:Y" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("I2")
'Region & District
repository.Range("AA2:AB" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("L2")
'Pay Terms
repository.Range("AQ2:AQ" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("N2")
'Revenue and Margin
repository.Range("L2:M" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("O2")
repository.Range("N2:N" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("R2")
repository.Range("O2:O" & lastRow).SpecialCells(xlCellTypeVisible).Copy listing.Range("S2") 'my guess is this is about where the problem is.
'Sort Data
listing.Columns("A:W").Sort key1:=listing.Range("P1"), order1:=xlDescending, Header:=xlYes
'Formulas
lastListingRow = listing.Cells(1000000, 1).End(xlUp).Row
listing.Range("Q2:Q" & lastListingRow).Formula = "=IFERROR(P2/O2,"""")"
listing.Range("T2:T" & lastListingRow).Formula = "=IFERROR(S2/R2,"""")"
listing.Range("U2:V" & lastListingRow).Formula = "=IFERROR(O2-R2,"""")"
listing.Range("W2:W" & lastListingRow).Formula = "=IFERROR(ROUND((Q2-T2)*10000,0),"""")"
'Paste formulas
'lastListingRow = listing.Cells(1000000, 1).End(xlUp).Row
'listing.Range("Q2").Copy listing.Range("Q3:Q" & listingLastRow)
'listing.Range("Q2").Copy listing.Range("T3:T" & listingLastRow)
'listing.Range("U2").Copy listing.Range("U3:V" & listingLastRow)
'listing.Range("W2").Copy listing.Range("W3:W" & listingLastRow)
If Dir(folderPath, vbDirectory) = "" Then
MkDir (folderPath)
End If
listing.Copy
Set newWb = Application.ActiveWorkbook
newWb.SaveAs folderPath & "\" & repDistrict & "-" & rep & "-" & repName & "-" & pivots.Range("H1"), FileFormat:=50
newWb.Close
listing.Range("A2:R9000").Value = ""
repository.ShowAllData
End If
Next
End Sub
I am not using option explicit as I tend to code mostly in python and have grown used to "duck typing".
I'd appreciate any help, and can clarify if you need it. I've never run into this problem before, but I've written several programs like it.
I don't know why this occurred, but I fixed it by replacing listing.Range("A2:R9000").Value = "" with listing.Rows("2:100000").delete.
Related
Good day all,
i am looking to alter the below VBA Code to send reminder to filtered range to each User based on specific text in column "H" "Send Reminder" and filtered range must be pasted into email below the body lines (Means Column A1:E1 by User wise filtered range).
Basically VBA code will reduce our work from more than hours to Milli seconds.
Problems encountered:
in our daily work we have so many todo list which needs to remind employee by employee wise with filtered list to each person will consume more than 2 hours to sort our data. Now the below code works but not filtered by User wise so its completely insufficient to use it properly. sending each email wise but filtered table also needs to place in the body of the emails is worthy. Hence time does not reduce much more than that.
Hence i am Looking to alter the below code as per my requirement.
Existing VBA Code:
Sub Send_Reminder()
Dim wStat As Range, i As Long
Dim dam As Object
For Each wStat In Range("H2", Range("H" & Rows.Count).End(xlUp))
If wStat.Value = "Send Reminder" Then
i = wStat.Row
Set dam = CreateObject("Outlook.Application").CreateItem(0)
dam.To = Range("I" & i).Value
dam.Cc = "" 'Range("F" & i).Value
dam.Subject = Range("B" & i).Value
dam.Body = "Hi " & Range("E" & i).Value & "," & vbCr & vbCr & _
"This is to remind you that " & Range("B" & wStat.Row).Value & " " & _
"Report is due today." & vbCr & vbCr & _
"Cheers!"
dam.FlagRequest = "Follow up" ' We set the Follow up Flag
dam.FlagDueBy = Format(DateAdd("d", 1, Date) + TimeValue("09:30:00"), "dd/mm/yyyy hh:mm") ' We set the due date for the reminder two days from today
dam.Display '.Sent
'
dam.Display '.Send
wStat.Value = "Sent"
End If
Next
MsgBox "Emails Sent"
End Sub
Not the best at VBA but I will give some context to help explain this probably stupid question.
The place I work for has a terrible system so we tend to do things our own way and use the system as little as possible.
We wanted to be able to take direct debits from customers as and when we need to and to do this we needed to create a 'BACS Standard 18' file to upload to the bank in order to collect the direct debits. The file requires there to be specific information about the transaction and it has to be displayed in a very specific way in notepad(txt).
I managed to create an Excel file that our finance team can use in order to create the file but when the file is created the typing cursor is always found to be a couple of lines under the exported text.
I need the text to be exported and the typing cursor to be at the end of the last line of the text, or a least not underneath. If it is under it, the bank will see that as a blank line and not accept the file. The number of lines in the file will always be different as well.
I have attached an example of the file in a screenshot. The highlighted part is what the file should include but as you can see the typing cursor is two lines lower.
Can someone please help with this and explain where I have gone wrong.
Thank you.
exportedfile
Below is the [vba] used to build the file and export the data from excel to notepad:
Sub Build_BACS()
LastRow = (Worksheets("Input").Range("Q2"))
'Header
ActiveSheet.Range("A1").Value = "=""VOL1""&Home!D5&"" ""&Home!D2&"" ""&""1"""
ActiveSheet.Range("A2").Value = "=""HDR1A""&Home!D2&""S""&"" ""&Home!D5&""00010001 ""&Home!D8&"" ""&Home!E8&"" 000000 """
ActiveSheet.Range("A3").Value = "=""HDR2F02000""&Home!B11&"" 00 """
ActiveSheet.Range("A4").Value = "=""UHL1 ""&Home!D8&""999999 000000001 DAILY 001 """
'Middle
ActiveSheet.Range("A5").Value = "=CONCAT(Input!C2,Input!D2,Input!K2,Input!G2,Input!H2,"" "",Input!L2,Input!M2,"" "",Input!N2,Input!O2)"
On Error Resume Next
Range("A5").AutoFill Destination:=Range("A5:A" & LastRow + 4), Type:=xlFillDefault
'Footer
If Sheets("Home").Range("A2").Value = "TMR" Or Sheets("Home").Range("A2").Value = "TMRF" Or Sheets("Home").Range("A2").Value = "TMREA" Then
Sheets("Output").Range("A" & LastRow + 5).Value = "=TEXT(Home!C2,""000000"")&TEXT(Home!B2,""00000000"")&""099""&TEXT(Home!C2,""000000"")&TEXT(Home!B2,""00000000"")&"" ""&TEXT(Input!P2,""00000000000"")&""The Mailing Room CONTRA TMR """
ElseIf Sheets("Home").Range("A2").Value = "DPS" Then
Sheets("Output").Range("A" & LastRow + 5).Value = "=TEXT(Home!C2,""000000"")&TEXT(Home!B2,""00000000"")&""099""&TEXT(Home!C2,""000000"")&TEXT(Home!B2,""00000000"")&"" ""&TEXT(Input!P2,""00000000000"")&""DPS CONTRA TMR """
End If
ActiveSheet.Range("A" & LastRow + 6).Value = "=""EOF1""&MID(A2,5,76)"
ActiveSheet.Range("A" & LastRow + 7).Value = "=""EOF2""&MID(A3,5,76)"
ActiveSheet.Range("A" & LastRow + 8).Value = "=""UTL1""&TEXT(Input!P2,""0000000000000"")&TEXT(Input!P2,""0000000000000"")&""0000001""&TEXT(Input!Q2,""0000000"")&"" """
'Export
Dim c As Range
Dim r As Range
Dim output As String
For Each r In Range("A1:A" & LastRow + 8).Rows
For Each c In r.Cells
output = output & c.Value
Next c
output = output & vbNewLine
Next r
Open ThisWorkbook.Path & "\" & ([Indirect("Home!B13")]) & ".txt" For Output As #1
Print #1, output
Close
InputBox "Noice." & Chr(13) & "Your file is just in here", "File Path", "Z:\My Documents\Orrin Lesiw\Direct Debit\Convert File"
End Sub
Adding ; to Print suppressed the vbNewLine. However output = output & vbNewLine will always add a newline so either add to front for lines 2 onwards like
Sub out2()
Dim c As Range
Dim r As Range
Dim output As String
For Each r In Range("A1:A" & LastRow + 8).Rows
If r.Row > 1 Then output = output & vbNewLine
For Each c In r.Cells
output = output & c.Value
Next c
Next r
Open ThisWorkbook.Path & "\" & ([Indirect("Home!B13")]) & ".txt" For Output As #1
Print #1, output;
Close
End Sub
or transpose the range into an array and use Join
' Export
Dim ar
ar = Application.Transpose(Range("A1:A" & LastRow + 8))
Open ThisWorkbook.Path & "\" & ([Indirect("Home!B13")]) & ".txt" For Output As #1
Print #1, Join(ar, vbNewLine);
Close
I've got an excel doc with 2 tabs. A data tab and a template tab. The data tab contains data in chunks equally spaced apart starting in row 52 (for this situation there's only three chunks). I want my code to copy some cells (the ones in gold) and paste it into the template tab. Then duplicate the template tab in another workbook to be saved and closed. Then it would go back to the original workbook and do the next chunk of data in the data tab till the end of all possible data (which will vary week over week, so like next week there could be 10 chunks).
Without the 'make new workbook and save' part of the code I can see it properly copy-pasting/cycling through to the end on my Template tab. So if it's plain like this, the data on the Template tab when done it's exactly the same as the last data set in the Data tab (aka the third chunk of the three total chunks of data with France + Nice). But when I add the new workbook+save feature it will properly do the 1st data chunk but then rapidly spirals into generating a bunch of empty excel docs that I have to ESC out of or will will never stop making them.
Dim i As Long, lastRow As Long
Set fnc = Sheets("France")
Set st = Sheets("Template")
lastRow = fnc.Cells(Rows.Count, "B").End(xlUp).Row
For i = 52 To lastRow
st.Range("B30").Value = fnc.Range("B" & i).Value
st.Range("C30").Value = fnc.Range("C" & i).Value
st.Range("D33").Value = fnc.Range("D" & i + 3).Value
st.Range("E33").Value = fnc.Range("E" & i + 3).Value
st.Range("F33").Value = fnc.Range("F" & i + 3).Value
st.Range("G33").Value = fnc.Range("G" & i + 3).Value
st.Range("H33").Value = fnc.Range("H" & i + 3).Value
Sheets("Template").Select
Sheets("Template").Copy
Sheets("Template").Name = "True Template"
If Dir("C:\Users\Edamame\Desktop\True Template", vbDirectory) = "" Then
MkDir ("C:\Users\Edamame\Desktop\True Template")
End If
ChDir ("C:\Users\Edamame\Desktop\True Template") ' Makes it save to the folder
Filename = "FW" & Format(Date, "ww") & "_" & Range("D30") & "_" & Range("B30") & "_True Template_" & Format(Date, "yyyy-mm-dd") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=Filename, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close False
Windows("Wine.xlsb").Activate
Next i
As per my comment:
Seems to me you are using empty cells to populate B30 and C30 if you go from 52 to lastRow. Try to include a Step 10 and check if that would work.
For i = 52 To lastRow Step 10
I currently have the following code for copying cells:
Set Feeder = Sheets("Projects").Range("B" & Rows.Count).End(xlUp)
With Sheets("Database")
Set Storage = .Range("C" & .Rows.Count).End(xlUp).Offset(-Masterrow + 1)
Storage.Value2 = "=" & "Projects!" & Feeder.Address
End With
Is there a way to incorporate the formula =IFERROR(B2,0) so that my copy location contains =IFERROR(Projects!B2,0) as opposed to =Projects!B2?
I want erroneous cells to return a 0 as opposed to an error code so I can just run my delete rows code easily.
The fix was straightforward after realizing I had already constructed a formula before.
Code from before:
Storage.Value2 = "=" & "Projects!" & Feeder.Address
Code after:
Storage.Value2 = "=" & "IFERROR(" & "Projects!" & Feeder.Address & ",0)"
Sometimes it really is simple!
I am very new to VBA programming and have an issue.
I have a base file called liquidity forecast in which I fill data from other documents in. The documents I collect data from is updated every day so the date in the name changes every day.
The Name goes "(Date, "YYMMDD") & "SE_Laizy.xlsx" so an example would be, 160229SE_Laizy.xlsx
When I collect data I use Index match formula. My problem is trying to update the link within the formula by using a date value.
Currently I write it like this,
ActiveCell.Range((Cells(1, 1)), (Cells(1, 1))).FormulaR1C1 = _
"=INDEX('[" & Format(Date, "YYMMDD") & "SE_Laizy.xlsx"]Visa'!R1:R1048576,MATCH(R2C,'[" & Format(Date, "YYMMDD") & "SE_Laizy.xlsx"]Visa'!C1,0),MATCH(""Ub perioden"",'[" & Format(Date, "YYMMDD") & "SE_Laizy.xlsx"]Visa'!R2,0))"
All I get from this is a NA. Any help would be appreciated!
I've added a parent worksheet reference and broken the INDEX and
MATCH functions into the three primary sections.
With Worksheets("Sheet2")
.Cells(1, 1).FormulaR1C1 = _
"=INDEX('[" & Format(Date, "YYMMDD") & "SE_Laizy.xlsx]Visa'!C1:C16384, " & _
"MATCH(R2C,'[" & Format(Date, "YYMMDD") & "SE_Laizy.xlsx]Visa'!C1, 0), " & _
"MATCH(""Ub perioden"", '[" & Format(Date, "YYMMDD") & "SE_Laizy.xlsx]Visa'!R2, 0))"
End With
As noted, there were some misplaced quotes in the external workbook name. I'm not sure what to do with your Range object definition. For all intents and purposes, the one supplied simply resolves down to [A1].