• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA Pull Purchases

Hello Nebu:

I would like to alter the code a bit if you don't mind.

I'd like to make the file pull ONLY the current year. As it is now it pulls leftovers, people that haven't paid yet, from the previous year (2015). I'd like the file year to year to pull ONLY the year it's ran for now that would be 2016, next year 2017, etc...

I need to also pull the "Amount" column [F] into the file. I have January and February pulled already and would like the code to ignore those as the entry isn't in spreadsheets any longer for the code to pull the amount from.

Here is the code as it is now:
Code: 
Sub DataExtract()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim i As Long
Dim j As Long
Dim k As Long
Dim o As Long
Dim s As Long
Dim objFSO As Object
Dim objFolder As Object
Dim objFile  As Object
Dim rng As Variant
Dim Rrng As Variant
Dim InvFound As Range
Dim wb As Workbook

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path & "\Statements\")

For Each objFile In objFolder.Files
  If InStr(objFile, ".xls") Then
  Workbooks.Open (objFile)
  End If
  Set wb = ActiveWorkbook
  i = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row + 1
  j = wb.Sheets("Statement").Cells(Rows.Count, "C").End(xlUp).Row
  With wb.Sheets("Statement").Range("B13:B" & j)
  Set InvFound = .Columns(1).Find(What:="PUR", LookIn:=xlValues)
  End With
  If Not InvFound Is Nothing Then
  wb.Sheets("Statement").Range("B12:I12").AutoFilter Field:=1, Criteria1:="PUR"
  wb.Sheets("Statement").Range("A13:E" & j).SpecialCells(xlCellTypeVisible).Copy
  Sheet1.Range("B" & i).PasteSpecial
  k = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
  wb.Sheets("Statement").Range("F6").Copy
  Sheet1.Range("A" & i & ":A" & k).PasteSpecial
  Application.CutCopyMode = False
  wb.Sheets("Statement").ShowAllData
  o = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
  rng = Sheet1.Range("B2:B" & o).Value
  Set Rrng = Sheet1.Range("G2:G" & o)
  On Error Resume Next
  For s = 1 To UBound(rng)
  Rrng(s, 1) = Month(rng(s, 1)) + 0
  Next
End If
wb.Close
Next
Sheet1.Range("A1:G" & o).RemoveDuplicates Columns:=4, Header:=xlYes
SplitSheets
Application.DisplayAlerts = False
Application.ScreenUpdating = True

End Sub

Sub SplitSheets()
Dim l As Long
Dim m As Long
Dim p As Long
Dim q As Long

l = Sheet14.Cells(Rows.Count, "A").End(xlUp).Row

For m = 2 To l

  Sheet1.Range("A1:G1").AutoFilter Field:=7, Criteria1:=Sheet14.Cells(m, 1).Value
  p = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
  Sheet1.Range("A2:F" & p).SpecialCells(xlCellTypeVisible).Copy
   
  If Sheet14.Range("A" & m).Value = 1 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet2.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 2 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet3.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet3.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 3 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet4.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet4.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 4 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet5.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet5.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 5 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet6.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet6.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 6 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet7.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet7.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 7 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet8.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet8.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 8 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet9.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet9.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 9 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet10.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet10.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 10 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet11.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet11.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 11 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet12.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet12.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  ElseIf Sheet14.Range("A" & m).Value = 12 And Sheet1.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2) <> vbNullString Then
  q = Sheet13.Cells(Rows.Count, "A").End(xlUp).Row + 1
  Sheet13.Range("A" & q).PasteSpecial
  Application.CutCopyMode = False
  End If
  Sheet1.ShowAllData
Next

MsgBox "Task Complete!"

End Sub
 
Hi:

I completely forgot what I have done for you. I need to refresh my memory, can you upload a sample file (both master and a couple for files from where you want to pull data) so that I can see what I have done . At a first glance I believe this will be fairly easy, provided if you have the year mentioned in your files from where the data is getting pulled. I am afraid that I understood what you said regarding the amount to be pulled excluding January and February. If the exclusion of Jan and Feb is a one-of issue I suggest you to do it manually rather than writing a code for it.

Thanks
 
Hi:

Sorry for the delay and I will get you the files later on but, for now, I have a question for you.

Do you, or could you recommend someone, work with Access? I used a template from Access called "Call Tracker" and I've made the changes I want but there is one thing I can't seem to wrap my head around implementing.

Thanks,
 
Hi:

I use access in my daily work, I get most of my solutions from web if I hit any roadblock. If you search in Google with proper keywords , I am sure you will be able to find solutions for your problem.

Thanks
 
You must log in or register to reply here.
Back
Top