VBA Code Help

[danny8890]

Hi,

I am currently using the below piece of code and it works without any problems.

I am wanting to make this a little better as currently it will move anything that is DIM to completed folder and then clears the contents in Sheet 1. The issue i've noticed is that some new subjects are coming in and they don't get copied as not created a DIM for them.

Is there anyway i can get this code to only move and clear the ones that were in DIM? rather than clear the whole sheets contents?

Thanks in advance

Sub New_MagicMacro()Dim i As Long, lastRow As Long
Dim sh As Worksheet


Dim j As Long, My_AH, My_SIM(), SIMcount As Long, My_DUP(), DUPcount As Long, My_UNL(), UNLcount As Long, My_DIS(), DIScount _
As Long, My_PORT(), PORTcount As Long, My_AGE(), AGEcount As Long, My_DDD(), DDDcount As Long, My_DISE(), DISEcount _
As Long, My_Bar(), BARcount As Long, My_PAC(), PACcount As Long, My_MIG(), MIGcount As Long, My_POP(), POPcount _
As Long, My_POU(), POUcount As Long, My_REC(), RECcount As Long, My_TOO(), TOOcount As Long, DDMcount As Long, JUCcount As Long


lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Application.DisplayAlerts = False


Columns("F:F").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("G1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Selection.NumberFormat = "m/d/yyyy"
    Columns("H:I").Select
    Selection.ClearContents


My_AH = Range("A2:H" & lastRow).Value
ReDim My_SIM(1 To lastRow - 1, 1 To 7)
ReDim My_DUP(1 To lastRow - 1, 1 To 7)
ReDim My_UNL(1 To lastRow - 1, 1 To 7)
ReDim My_DIS(1 To lastRow - 1, 1 To 7)
ReDim My_PORT(1 To lastRow - 1, 1 To 7)
ReDim My_AGE(1 To lastRow - 1, 1 To 7)
ReDim My_DDD(1 To lastRow - 1, 1 To 7)
ReDim My_DISE(1 To lastRow - 1, 1 To 7)
ReDim My_Bar(1 To lastRow - 1, 1 To 7)
ReDim My_PAC(1 To lastRow - 1, 1 To 7)
ReDim My_MIG(1 To lastRow - 1, 1 To 7)
ReDim My_POP(1 To lastRow - 1, 1 To 7)
ReDim My_POU(1 To lastRow - 1, 1 To 7)
ReDim My_REC(1 To lastRow - 1, 1 To 7)
ReDim My_TOO(1 To lastRow - 1, 1 To 7)
ReDim My_DDM(1 To lastRow - 1, 1 To 7)
ReDim My_JUC(1 To lastRow - 1, 1 To 7)


For i = 1 To lastRow - 1
  If (My_AH(i, 1) Like "*SIM*") Or (My_AH(i, 1) Like "*SSN*") Or (My_AH(i, 1) Like "*Sim*") Or (My_AH(i, 1) Like "*O2 Retail*") _
  Then
    SIMcount = SIMcount + 1
    For j = 1 To 7
      My_SIM(SIMcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Duplicate*" Then
    DUPcount = DUPcount + 1
    For j = 1 To 7
      My_DUP(DUPcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Unlatching*" Then
    UNLcount = UNLcount + 1
    For j = 1 To 7
      My_UNL(UNLcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Dispute*" Then
    DIScount = DIScount + 1
    For j = 1 To 7
      My_DIS(DIScount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Port*" Then
    PORTcount = PORTcount + 1
    For j = 1 To 7
      My_PORT(PORTcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Age Verification*" Then
    AGEcount = AGEcount + 1
    For j = 1 To 7
      My_AGE(AGEcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Direct Debit Date*" Then
    DDDcount = DDDcount + 1
    For j = 1 To 7
      My_DDD(DDDcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*DISE to Pay*" Then
    DISEcount = DISEcount + 1
    For j = 1 To 7
      My_DISE(DISEcount, j) = My_AH(i, j)
    Next j
  End If
  If My_AH(i, 1) Like "*Handset Barring*" Then
    BARcount = BARcount + 1
    For j = 1 To 7
      My_Bar(BARcount, j) = My_AH(i, j)
    Next j
  End If
   If My_AH(i, 1) Like "*PAC Request*" Then
    PACcount = PACcount + 1
    For j = 1 To 7
      My_PAC(PACcount, j) = My_AH(i, j)
    Next j
  End If
  If (My_AH(i, 1) Like "*Pay & Go to Pay Monthly Migration*") Or (My_AH(i, 1) Like "*Pay And Go To Pay Monthly Migration*") Then
    MIGcount = MIGcount + 1
    For j = 1 To 7
      My_MIG(MIGcount, j) = My_AH(i, j)
    Next j
  End If
  If (My_AH(i, 1) Like "*Proof of Purchase*") Then
    POPcount = POPcount + 1
    For j = 1 To 7
      My_POP(POPcount, j) = My_AH(i, j)
    Next j
  End If
   If (My_AH(i, 1) Like "*Proof of Usage*") Then
    POUcount = POUcount + 1
    For j = 1 To 7
      My_POU(POUcount, j) = My_AH(i, j)
    Next j
  End If
  If (My_AH(i, 1) Like "*Reconnection*") Then
    RECcount = RECcount + 1
    For j = 1 To 7
      My_REC(RECcount, j) = My_AH(i, j)
    Next j
  End If
   If (My_AH(i, 1) Like "*Transfer of ownership*") Then
    TOOcount = TOOcount + 1
    For j = 1 To 7
      My_TOO(TOOcount, j) = My_AH(i, j)
    Next j
  End If
  If (My_AH(i, 1) Like "*Direct Debit Mandate Request*") Then
    DDMcount = DDMcount + 1
    For j = 1 To 7
      My_DDM(DDMcount, j) = My_AH(i, j)
    Next j
  End If
  If (My_AH(i, 1) Like "*JUC Cease*") Then
    JUCcount = JUCcount + 1
    For j = 1 To 7
      My_JUC(JUCcount, j) = My_AH(i, j)
    Next j
  End If
  
Next i
If SIMcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(SIMcount, 7).Value = My_SIM
If DUPcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DUPcount, 7).Value = My_DUP
If UNLcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UNLcount, 7).Value = My_UNL
If DIScount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DIScount, 7).Value = My_DIS
If PORTcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(PORTcount, 7).Value = My_PORT
If AGEcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(AGEcount, 7).Value = My_AGE
If DDDcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DDDcount, 7).Value = My_DDD
If DISEcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DISEcount, 7).Value = My_DISE
If BARcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(BARcount, 7).Value = My_Bar
If PACcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(PACcount, 7).Value = My_PAC
If MIGcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(MIGcount, 7).Value = My_MIG
If POPcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(POPcount, 7).Value = My_POP
If POUcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(POUcount, 7).Value = My_POU
If RECcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(RECcount, 7).Value = My_REC
If TOOcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(TOOcount, 7).Value = My_TOO
If DDMcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(DDMcount, 7).Value = My_DDM
If JUCcount > 0 Then Sheets("Complete").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(JUCcount, 7).Value = My_JUC


Sheets("Sheet1").Range("A2:G50000").ClearContents


For Each sh In Worksheets
    If sh.Name <> "Lookup" Then
    If sh.Name <> "Sheet1" Then
    If sh.Name <> "Sheet2" Then
    If sh.Name <> "Sheet3" Then
    sh.Cells.WrapText = False
    sh.Range("H2:N2").AutoFill Destination:=sh.Range("H2:N" & sh.Range("A" & Rows.Count).End(xlUp).Row)
    sh.Columns("$A:$K").RemoveDuplicates Columns:=Array(1), Header:=xlYes
End If
End If
End If
End If
Next sh


MsgBox "Finished"
End Sub

 

[Fluff]

On option would be to add this line

For j = 1 To 7
  My_SIM(SIMcount, j) = my_AH(i, j)
 [COLOR=#0000ff] my_AH(i, j) = ""[/COLOR]
Next j

to all your For j loops & then write the array back to the sheet, after clearing it.

 

[danny8890]

Hi,

Thanks for you reply, So Would this only write it back to the sheet if it hasn't been copied to "Complete" if i write the array back to the sheet

On option would be to add this line

For j = 1 To 7
  My_SIM(SIMcount, j) = my_AH(i, j)
 [COLOR=#0000ff] my_AH(i, j) = ""[/COLOR]
Next j

to all your For j loops & then write the array back to the sheet, after clearing it.

 

[Fluff]

That's simply clearing values in the original array is they are being copied to a new array.
So the only data left in the original array will be the stuff that did not get copied.
You'll need to either sort the data after copying back to the sheet, or delete blank rows.

 

[danny8890]

Makes sense thanks, I've added the extra line of code back in, I've had a go at trying to write the array back after clear contents but to no luck, had a search around too but still not luck, Could you assist with the coded to write it array back?, not sure how to do it, The code i'm using was kindly re wrote to speed the process up to what i originally had i know how to add new stuff to this and amend but still learning in terms of writing new code.

Thanks

 

[Fluff]

try

Sheets("Sheet1").Range("A2").Resize(UBound(My_AH), 8).Value = My_AH

 

[danny8890]

Works Perfectly!, Thanks!

 

[danny8890]

Also added line of code to remove all the blank rows

sh.Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

 

[Fluff]

Glad to help & thanks for the feedback