Yet Another Sheet Name Copying based on Cell Value Problem

airforceone

airforceone

Board Regular
Joined
Feb 14, 2022
Messages
177
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
the idea is to copy range of record(s) from source to created sheet (sheet based on cell value)
problem is copying should start at row 2 of every target sheet but the my module copies the next range of record(s) to the row from the last row of previous sheet (running the code would explained it better :))

VBA Code: 
Sub DATE2SHEET()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

'    Dim LRow As Long, cTr As Long, MyRange As range
    Dim ictr As Long
    Dim arrVA, xctr
    Dim dOBJ As Object
    Dim ws As Worksheet
  
    With Sheets(1)
        arrVA = .range("A2", .Cells(.rows.Count, "A").End(xlUp))
    End With
    Set dOBJ = CreateObject("scripting.dictionary")
    For ictr = 1 To UBound(arrVA, 1)
        dOBJ(arrVA(ictr, 1)) = 1
    Next
    ReDim arrVA(1 To dOBJ.Count, 1 To 1)
    ictr = 0
    For Each xctr In dOBJ.keys
       ictr = ictr + 1
       arrVA(ictr, 1) = xctr
    Next
    range("B2").Resize(UBound(arrVA, 1), 1) = arrVA

'-------------------------------------------------
'   Module to Set / Create Sheet based on Unique Month Value
    Set ws = Worksheets(1)
    LRow = range("A" & rows.Count).End(xlUp).Row
    cTr = 2
    Do Until cTr > LRow
        Cells(cTr, 5) = Choose(Month(Cells(cTr, 4)), "JANUARY", "FEBRUARY", "MARCH", "APRIL", "MAY", "JUNE", "JULY", "AUGUST", "SEPTEMBER", "OCTOBER", "NOVEMBER", "DECEMBER")
        cTr = cTr + 1
    Loop

'-------------------------------------------------
'   DUPLICATE SOURCE SHEET
    Sheets("SPECIE").Select
    Sheets("SPECIE").Copy After:=Sheets(1)
    Sheets("SPECIE (2)").name = "MonthName"
    Set WSCopy = ActiveSheet
    ActiveSheet.Select
    Application.WindowState = xlMaximized
        
'-------------------------------------------------
'   DELETE DUPLICATE ENTRY
    Sheets("MonthName").UsedRange.RemoveDuplicates Columns:=5, Header:=xlNo
    Set MyRange = range("E1:E" & LRow)
    For Each cell In MyRange
        If Not IsEmpty(cell) Then
            Sheets.Add(After:=Sheets(2)).name = cell    '   may use SheetCount variable
        End If
    Next cell

'-------------------------------------------------
'   DELETE UPDATED SHEET
    Sheets("MonthName").Delete

'-------------------------------------------------
'   COPY TO MONTH SHEET NAME
    Dim shtSource As Worksheet, wsName As String
    Set shtSource = Worksheets("SPECIE")
    LRow = Sheets("SPECIE").range("A" & rows.Count).End(xlUp).Row
    
    cTr = 2
    iLOOP = 2
    Do Until cTr > LRow
        wsName = shtSource.Cells(cTr, "E")
        If Evaluate("isref('" & wsName & "'!A1)") Then shtSource.rows(cTr).Copy Worksheets(wsName).range("A" & iLOOP)
        End If
        iLOOP = iLOOP + 1
        cTr = cTr + 1
    Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
    MsgBox " >>> Processed Complete! <<< ", vbInformation + vbOKOnly

End Sub     '   END OF MODULE DATE2SHEET()




00 DUMMY RECORD.xlsx
ABCDE
1SPECIE NUMBERSPECIESTATUSDATE ENTEREDMONTH
2A00296A00296SHIPPED2022.09.10
3A00297A00297SHIPPED2022.09.10
4A00298A00298SHIPPED2022.09.10
5A00299A00299SHIPPED2022.09.10
6A00300A00300SHIPPED2022.09.10
7A00295A00295SHIPPED2022.09.08
8A00294A00294SHIPPED2022.09.06
9A00293A00293SHIPPED2022.09.03
10A00289A00289SHIPPED2022.09.01
11A00290A00290SHIPPED2022.09.01
12A00291A00291SHIPPED2022.09.01
13A00292A00292SHIPPED2022.09.01
14A00288A00288SHIPPED2022.08.30
15A00286A00286SHIPPED2022.08.29
16A00287A00287CLEARED2022.08.29
17A00285A00285SHIPPED2022.08.28
18A00283A00283SHIPPED2022.08.27
19A00284A00284SHIPPED2022.08.27
20A00282A00282SHIPPED2022.08.26
21A00281A00281CLEARED2022.08.22
22A00279A00279CLEARED2022.08.20
23A00280A00280SHIPPED2022.08.20
24A00277A00277SHIPPED2022.08.19
25A00278A00278SHIPPED2022.08.19
26A00275A00275SHIPPED2022.08.18
27A00276A00276SHIPPED2022.08.18
28A00271A00271SHIPPED2022.08.16
29A00272A00272SHIPPED2022.08.16
30A00273A00273SHIPPED2022.08.16
31A00274A00274SHIPPED2022.08.16
32A00269A00269SHIPPED2022.08.13
33A00270A00270SHIPPED2022.08.13
34A00268A00268UNDELIVERED2022.08.12
35A00267A00267SHIPPED2022.08.11
36A00264A00264PENDING2022.08.10
37A00265A00265SHIPPED2022.08.10
38A00266A00266SHIPPED2022.08.10
39A00260A00260SHIPPED2022.08.08
40A00261A00261SHIPPED2022.08.08
41A00262A00262SHIPPED2022.08.08
42A00263A00263SHIPPED2022.08.08
43A00259A00259CLEARED2022.08.06
44A00258A00258SHIPPED2022.08.04
45A00254A00254SHIPPED2022.08.02
46A00255A00255SHIPPED2022.08.02
47A00256A00256SHIPPED2022.08.02
48A00257A00257SHIPPED2022.08.02
49A00252A00252SHIPPED2022.08.01
50A00253A00253SHIPPED2022.08.01
51A00250A00250SHIPPED2022.07.31
52A00251A00251SHIPPED2022.07.31
53A00249A00249CLEARED2022.07.29
54A00247A00247SHIPPED2022.07.24
55A00248A00248SHIPPED2022.07.24
56A00244A00244CLEARED2022.07.22
57A00245A00245SHIPPED2022.07.22
58A00246A00246SHIPPED2022.07.22
59A00243A00243CLEARED2022.07.21
60A00238A00238CLEARED2022.07.19
61A00239A00239SHIPPED2022.07.19
62A00240A00240SHIPPED2022.07.19
63A00241A00241SHIPPED2022.07.19
64A00242A00242SHIPPED2022.07.19
65A00234A00234SHIPPED2022.07.18
66A00235A00235SHIPPED2022.07.18
67A00236A00236SHIPPED2022.07.18
68A00237A00237SHIPPED2022.07.18
69A00232A00232SHIPPED2022.07.17
70A00233A00233SHIPPED2022.07.17
71A00231A00231CLEARED2022.07.14
72A00230A00230PENDING2022.07.13
73A00228A00228SHIPPED2022.07.12
74A00229A00229SHIPPED2022.07.12
75A00225A00225CLEARED2022.07.08
76A00226A00226SHIPPED2022.07.08
77A00227A00227SHIPPED2022.07.08
78A00224A00224CLEARED2022.07.07
79A00220A00220SHIPPED2022.07.05
80A00221A00221SHIPPED2022.07.05
81A00222A00222SHIPPED2022.07.05
82A00223A00223SHIPPED2022.07.05
83A00219A00219SHIPPED2022.07.04
84A00218A00218SHIPPED2022.07.02
85A00217A00217SHIPPED2022.07.01
86A00214A00214SHIPPED2022.06.30
87A00215A00215SHIPPED2022.06.30
88A00216A00216CLEARED2022.06.30
89A00212A00212SHIPPED2022.06.29
90A00213A00213SHIPPED2022.06.29
91A00210A00210SHIPPED2022.06.26
92A00211A00211SHIPPED2022.06.26
93A00200A00200SHIPPED2022.06.25
94A00201A00201SHIPPED2022.06.25
95A00202A00202SHIPPED2022.06.25
96A00203A00203SHIPPED2022.06.25
97A00204A00204PENDING2022.06.25
98A00205A00205PENDING2022.06.25
99A00206A00206SHIPPED2022.06.25
100A00207A00207SHIPPED2022.06.25
101A00208A00208SHIPPED2022.06.25
102A00209A00209SHIPPED2022.06.25
103A00199A00199CLEARED2022.06.24
104A00198A00198CLEARED2022.06.22
105A00196A00196CLEARED2022.06.17
106A00197A00197CLEARED2022.06.17
107A00194A00194SHIPPED2022.06.16
108A00195A00195SHIPPED2022.06.16
109A00192A00192SHIPPED2022.06.12
110A00193A00193SHIPPED2022.06.12
111A00190A00190SHIPPED2022.06.09
112A00191A00191SHIPPED2022.06.09
113A00189A00189CLEARED2022.06.07
114A00187A00187CLEARED2022.06.03
115A00188A00188SHIPPED2022.06.03
116A00186A00186SHIPPED2022.06.01
117A00184A00184CLEARED2022.05.26
118A00185A00185CLEARED2022.05.26
119A00177A00177CLEARED2022.05.24
120A00178A00178CLEARED2022.05.24
121A00179A00179CLEARED2022.05.24
122A00180A00180SHIPPED2022.05.24
123A00181A00181SHIPPED2022.05.24
124A00182A00182SHIPPED2022.05.24
125A00183A00183SHIPPED2022.05.24
126A00175A00175CLEARED2022.05.23
127A00176A00176CLEARED2022.05.23
128A00173A00173SHIPPED2022.05.21
129A00174A00174SHIPPED2022.05.21
130A00172A00172CLEARED2022.05.20
131A00168A00168SHIPPED2022.05.19
132A00169A00169SHIPPED2022.05.19
133A00170A00170SHIPPED2022.05.19
134A00171A00171SHIPPED2022.05.19
135A00166A00166PENDING2022.05.15
136A00167A00167CLEARED2022.05.15
137A00161A00161PENDING2022.05.14
138A00162A00162SHIPPED2022.05.14
139A00163A00163SHIPPED2022.05.14
140A00164A00164SHIPPED2022.05.14
141A00165A00165SHIPPED2022.05.14
142A00159A00159SHIPPED2022.05.13
143A00160A00160SHIPPED2022.05.13
144A00156A00156CLEARED2022.05.12
145A00157A00157SHIPPED2022.05.12
146A00158A00158SHIPPED2022.05.12
147A00154A00154SHIPPED2022.05.11
148A00155A00155CLEARED2022.05.11
149A00153A00153SHIPPED2022.05.10
150A00151A00151SHIPPED2022.05.09
151A00152A00152SHIPPED2022.05.09
152A00149A00149SHIPPED2022.05.07
153A00150A00150SHIPPED2022.05.07
154A00147A00147SHIPPED2022.05.05
155A00148A00148SHIPPED2022.05.05
156A00145A00145SHIPPED2022.05.03
157A00146A00146SHIPPED2022.05.03
158A00144A00144SHIPPED2022.05.02
159A00141A00141PENDING2022.04.30
160A00142A00142SHIPPED2022.04.30
161A00143A00143SHIPPED2022.04.30
162A00138A00138PENDING2022.04.28
163A00139A00139PENDING2022.04.28
164A00140A00140PENDING2022.04.28
165A00137A00137SHIPPED2022.04.27
166A00131A00131SHIPPED2022.04.26
167A00132A00132SHIPPED2022.04.26
168A00133A00133SHIPPED2022.04.26
169A00134A00134SHIPPED2022.04.26
170A00135A00135SHIPPED2022.04.26
171A00136A00136SHIPPED2022.04.26
172A00129A00129SHIPPED2022.04.22
173A00130A00130SHIPPED2022.04.22
174A00125A00125CLEARED2022.04.21
175A00126A00126CLEARED2022.04.21
176A00127A00127SHIPPED2022.04.21
177A00128A00128CLEARED2022.04.21
178A00121A00121SHIPPED2022.04.19
179A00122A00122SHIPPED2022.04.19
180A00123A00123SHIPPED2022.04.19
181A00124A00124SHIPPED2022.04.19
182A00119A00119UNDELIVERED2022.04.18
183A00120A00120UNDELIVERED2022.04.18
184A00117A00117SHIPPED2022.04.15
185A00118A00118SHIPPED2022.04.15
186A00116A00116SHIPPED2022.04.12
187A00115A00115PENDING2022.04.11
188A00109A00109SHIPPED2022.04.10
189A00110A00110SHIPPED2022.04.10
190A00111A00111SHIPPED2022.04.10
191A00112A00112SHIPPED2022.04.10
192A00113A00113SHIPPED2022.04.10
193A00114A00114SHIPPED2022.04.10
194A00108A00108SHIPPED2022.04.09
195A00107A00107SHIPPED2022.04.07
196A00106A00106CLEARED2022.04.04
197A00104A00104PENDING2022.04.01
198A00105A00105PENDING2022.04.01
199A00102A00102SHIPPED2022.03.30
200A00103A00103SHIPPED2022.03.30
201A00099A00099PENDING2022.03.25
202A00100A00100SHIPPED2022.03.25
203A00101A00101PENDING2022.03.25
204A00096A00096CLEARED2022.03.24
205A00097A00097SHIPPED2022.03.24
206A00098A00098SHIPPED2022.03.24
207A00093A00093SHIPPED2022.03.23
208A00094A00094SHIPPED2022.03.23
209A00095A00095CLEARED2022.03.23
210A00091A00091SHIPPED2022.03.22
211A00092A00092SHIPPED2022.03.22
212A00089A00089SHIPPED2022.03.20
213A00090A00090SHIPPED2022.03.20
214A00088A00088CLEARED2022.03.18
215A00083A00083PENDING2022.03.16
216A00084A00084CLEARED2022.03.16
217A00085A00085PENDING2022.03.16
218A00086A00086PENDING2022.03.16
219A00087A00087SHIPPED2022.03.16
220A00082A00082SHIPPED2022.03.15
221A00080A00080SHIPPED2022.03.13
222A00081A00081SHIPPED2022.03.13
223A00079A00079CLEARED2022.03.10
224A00077A00077PENDING2022.03.08
225A00078A00078PENDING2022.03.08
226A00074A00074CLEARED2022.03.05
227A00075A00075PENDING2022.03.05
228A00076A00076PENDING2022.03.05
229A00072A00072SHIPPED2022.03.04
230A00073A00073SHIPPED2022.03.04
231A00071A00071PENDING2022.03.01
232A00069A00069SHIPPED2022.02.28
233A00070A00070SHIPPED2022.02.28
234A00064A00064CLEARED2022.02.27
235A00065A00065SHIPPED2022.02.27
236A00066A00066PENDING2022.02.27
237A00067A00067PENDING2022.02.27
238A00068A00068SHIPPED2022.02.27
239A00061A00061PENDING2022.02.26
240A00062A00062SHIPPED2022.02.26
241A00063A00063SHIPPED2022.02.26
242A00058A00058PENDING2022.02.25
243A00059A00059PENDING2022.02.25
244A00060A00060SHIPPED2022.02.25
245A00057A00057CLEARED2022.02.23
246A00056A00056SHIPPED2022.02.22
247A00054A00054SHIPPED2022.02.21
248A00055A00055SHIPPED2022.02.21
249A00053A00053CLEARED2022.02.18
250A00052A00052CLEARED2022.02.17
251A00048A00048SHIPPED2022.02.15
252A00049A00049SHIPPED2022.02.15
253A00050A00050SHIPPED2022.02.15
254A00051A00051SHIPPED2022.02.15
255A00047A00047PENDING2022.02.14
256A00043A00043PENDING2022.02.13
257A00044A00044SHIPPED2022.02.13
258A00045A00045SHIPPED2022.02.13
259A00046A00046SHIPPED2022.02.13
260A00042A00042SHIPPED2022.02.08
261A00039A00039SHIPPED2022.02.07
262A00040A00040SHIPPED2022.02.07
263A00041A00041SHIPPED2022.02.07
264A00037A00037CLEARED2022.02.03
265A00038A00038SHIPPED2022.02.03
266A00034A00034PENDING2022.02.02
267A00035A00035SHIPPED2022.02.02
268A00036A00036SHIPPED2022.02.02
269A00033A00033PENDING2022.01.30
270A00030A00030CLEARED2022.01.27
271A00031A00031SHIPPED2022.01.27
272A00032A00032SHIPPED2022.01.27
273A00028A00028SHIPPED2022.01.22
274A00029A00029SHIPPED2022.01.22
275A00025A00025CLEARED2022.01.20
276A00026A00026SHIPPED2022.01.20
277A00027A00027SHIPPED2022.01.20
278A00022A00022SHIPPED2022.01.19
279A00023A00023SHIPPED2022.01.19
280A00024A00024SHIPPED2022.01.19
281A00021A00021PENDING2022.01.17
282A00020A00020CLEARED2022.01.15
283A00018A00018PENDING2022.01.14
284A00019A00019SHIPPED2022.01.14
285A00016A00016SHIPPED2022.01.13
286A00017A00017SHIPPED2022.01.13
287A00014A00014SHIPPED2022.01.12
288A00015A00015SHIPPED2022.01.12
289A00012A00012SHIPPED2022.01.11
290A00013A00013SHIPPED2022.01.11
291A00011A00011PENDING2022.01.09
292A00009A00009SHIPPED2022.01.08
293A00010A00010SHIPPED2022.01.08
294A00007A00007PENDING2022.01.07
295A00008A00008SHIPPED2022.01.07
296A00006A00006PENDING2022.01.06
297A00002A00002PENDING2022.01.05
298A00003A00003SHIPPED2022.01.05
299A00004A00004SHIPPED2022.01.05
300A00005A00005SHIPPED2022.01.05
301A00001A00001CLEARED2022.01.02
SPECIE
 
Sort by date Sort by votes
Just had a look and got it done a bit quicker than I thought I would, just not quite quick enough to edit my last reply and add the code to it.

New sheets created using MMM-YY naming format. Assumed that there are currently no month sheets in the workbook (an error trap will be needed if there are).
Also assumed that SPECIE sheet is in chronological order.

Still not convinced that the first part of the code is necessary (arrVA etc).

I'll try and answer any questions that you might have, but writing code on my phone is near impossible so my replies will be very limited while I'm away.

VBA Code: 
Option Explicit
Sub DATE2SHEET()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

'    Dim LRow As Long, cTr As Long, MyRange As range
    Dim ictr As Long
    Dim arrVA, xctr
    Dim dOBJ As Object
    Dim ws As Worksheet
  
    With Sheets(1)
        arrVA = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
    End With
    Set dOBJ = CreateObject("scripting.dictionary")
    For ictr = 1 To UBound(arrVA, 1)
        dOBJ(arrVA(ictr, 1)) = 1
    Next
    ReDim arrVA(1 To dOBJ.Count, 1 To 1)
    ictr = 0
    For Each xctr In dOBJ.keys
       ictr = ictr + 1
       arrVA(ictr, 1) = xctr
    Next
    Range("B2").Resize(UBound(arrVA, 1), 1) = arrVA

'
'-------------------------------------------------
'   COPY TO MONTH SHEET NAME
    Dim lrow As Long, c As Range, rCopy As Range
    
    With Worksheets("SPECIE")
        Set rCopy = .Range("A1:D1")
        lrow = .Range("A" & Rows.Count).End(xlUp).Row
        
        For Each c In .Range("D2:D" & lrow)
            If Format(c.Value, "MMM-YY") <> Format(c.Offset(1), "MMM-YY") Then
                
                With Sheets.Add(, Sheets(1))
                    .Name = Format(c.Value, "MMM-YY")
                
                    rCopy.Copy .Range("A1")
                    .Columns.AutoFit
                End With
                Set rCopy = .Range("A1:D1")
            Else
                Set rCopy = Union(.Range("A1:D1"), rCopy, c.Offset(, -3).Resize(, 4))
            End If
        Next
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
    MsgBox " >>> Processed Complete! <<< ", vbInformation + vbOKOnly

End Sub     '   END OF MODULE DATE2SHEET()
 
Upvote 0

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
jasonb75 said:
Currently the code only looks at month, there would be no differentiation between years. Although I used a completely different method, I based the process on your original code (and the data sample), from which it appeared that the data would only cover a single year.

Would you want Jan 2021 at the bottom of the same sheet as Jan 2020, or on a separate sheet?
Assuming separate sheets, how would you want them named? Personal preference would be a format like Jan-22 in order to keep tab sizes reasonable.
I'll need to change the way that the new sheets are added to allow for this so will make it dynamic at the same time.

On a side note, I've only got a few hours then I'm going to be away for about 5 days. I'll try and get a new version done before I leave based on how I think you might want it based on a few assumptions, but I wouldn't be able to make any subsequent changes until after I get back.
Click to expand...
no worries mate, just thinking out loud :) but if I may take advantage of your generosity report may span 3 - 6 years period. safe trip mate...
 
Upvote 0
h
jasonb75 said:
Just had a look and got it done a bit quicker than I thought I would, just not quite quick enough to edit my last reply and add the code to it.

New sheets created using MMM-YY naming format. Assumed that there are currently no month sheets in the workbook (an error trap will be needed if there are).
Also assumed that SPECIE sheet is in chronological order.

Still not convinced that the first part of the code is necessary (arrVA etc).

I'll try and answer any questions that you might have, but writing code on my phone is near impossible so my replies will be very limited while I'm away.

VBA Code: 
Option Explicit
Sub DATE2SHEET()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

'    Dim LRow As Long, cTr As Long, MyRange As range
    Dim ictr As Long
    Dim arrVA, xctr
    Dim dOBJ As Object
    Dim ws As Worksheet
 
    With Sheets(1)
        arrVA = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
    End With
    Set dOBJ = CreateObject("scripting.dictionary")
    For ictr = 1 To UBound(arrVA, 1)
        dOBJ(arrVA(ictr, 1)) = 1
    Next
    ReDim arrVA(1 To dOBJ.Count, 1 To 1)
    ictr = 0
    For Each xctr In dOBJ.keys
       ictr = ictr + 1
       arrVA(ictr, 1) = xctr
    Next
    Range("B2").Resize(UBound(arrVA, 1), 1) = arrVA

'
'-------------------------------------------------
'   COPY TO MONTH SHEET NAME
    Dim lrow As Long, c As Range, rCopy As Range
   
    With Worksheets("SPECIE")
        Set rCopy = .Range("A1:D1")
        lrow = .Range("A" & Rows.Count).End(xlUp).Row
       
        For Each c In .Range("D2:D" & lrow)
            If Format(c.Value, "MMM-YY") <> Format(c.Offset(1), "MMM-YY") Then
               
                With Sheets.Add(, Sheets(1))
                    .Name = Format(c.Value, "MMM-YY")
               
                    rCopy.Copy .Range("A1")
                    .Columns.AutoFit
                End With
                Set rCopy = .Range("A1:D1")
            Else
                Set rCopy = Union(.Range("A1:D1"), rCopy, c.Offset(, -3).Resize(, 4))
            End If
        Next
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
   
    MsgBox " >>> Processed Complete! <<< ", vbInformation + vbOKOnly

End Sub     '   END OF MODULE DATE2SHEET()
Click to expand...
have not seen it will try it out mate thanks again... (did not see it while replying to your previous post :))
 
Upvote 0
jasonb75 said:
Just had a look and got it done a bit quicker than I thought I would, just not quite quick enough to edit my last reply and add the code to it.

New sheets created using MMM-YY naming format. Assumed that there are currently no month sheets in the workbook (an error trap will be needed if there are).
Also assumed that SPECIE sheet is in chronological order.

Still not convinced that the first part of the code is necessary (arrVA etc).

I'll try and answer any questions that you might have, but writing code on my phone is near impossible so my replies will be very limited while I'm away.

VBA Code: 
Option Explicit
Sub DATE2SHEET()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

'    Dim LRow As Long, cTr As Long, MyRange As range
    Dim ictr As Long
    Dim arrVA, xctr
    Dim dOBJ As Object
    Dim ws As Worksheet
 
    With Sheets(1)
        arrVA = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
    End With
    Set dOBJ = CreateObject("scripting.dictionary")
    For ictr = 1 To UBound(arrVA, 1)
        dOBJ(arrVA(ictr, 1)) = 1
    Next
    ReDim arrVA(1 To dOBJ.Count, 1 To 1)
    ictr = 0
    For Each xctr In dOBJ.keys
       ictr = ictr + 1
       arrVA(ictr, 1) = xctr
    Next
    Range("B2").Resize(UBound(arrVA, 1), 1) = arrVA

'
'-------------------------------------------------
'   COPY TO MONTH SHEET NAME
    Dim lrow As Long, c As Range, rCopy As Range
  
    With Worksheets("SPECIE")
        Set rCopy = .Range("A1:D1")
        lrow = .Range("A" & Rows.Count).End(xlUp).Row
      
        For Each c In .Range("D2:D" & lrow)
            If Format(c.Value, "MMM-YY") <> Format(c.Offset(1), "MMM-YY") Then
              
                With Sheets.Add(, Sheets(1))
                    .Name = Format(c.Value, "MMM-YY")
              
                    rCopy.Copy .Range("A1")
                    .Columns.AutoFit
                End With
                Set rCopy = .Range("A1:D1")
            Else
                Set rCopy = Union(.Range("A1:D1"), rCopy, c.Offset(, -3).Resize(, 4))
            End If
        Next
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
  
    MsgBox " >>> Processed Complete! <<< ", vbInformation + vbOKOnly

End Sub     '   END OF MODULE DATE2SHEET()
Click to expand...
at first it seems working but some entries were missing as per date is concern...
i.e. January 2021 has 3 but showing only 2 while January 2022 has 2 showing only 1
sample table as follow....

00 CURRENT TABLE SOURCE.xlsx
ABCDE
1SPECIE NUMBERSPECIESTATUSDATE ENTEREDMONTH
2A00001VipersSold2021.01.02
3A00030PseudoxyrhophiidsSold2021.01.02
4A00031PythonsHatched2021.01.02
5A00032PseudaspididsHatched2022.01.27
6A00033Shovel-Snout Cleared2022.01.30
7A00034PsammophiidsCleared2022.02.02
8A00071Sunbeam Cleared2022.03.01
9A00072False Coral Hatched2022.03.04
10A00102PseudaspididsHatched2022.03.30
11A00103PseudoxyrhophiidsHatched2022.03.30
12A00104PythonsCleared2022.04.01
13A00105Mexican BurrowingCleared2022.04.01
14A00106Snail-Eating Sold2022.04.04
15A00107Shovel-Snout Hatched2022.04.07
16A00108LamprophiidsHatched2022.04.09
17A00141Splitjaw Cleared2022.04.30
18A00142VipersHatched2022.04.30
19A00143Dragon Scaled Hatched2022.04.30
20A00144Sunbeam Hatched2022.05.02
21A00145Spine-Jawed Hatched2022.05.03
22A00146Shield-Tailed Hatched2022.05.03
23A00184False Coral Sold2022.05.26
24A00185Dwarf Pipe Sold2022.05.26
25A00186Burrowing AspsHatched2022.06.01
26A00214VipersHatched2022.06.30
27A00215Dragon Scaled Hatched2022.06.30
28A00216Shield-Tailed Sold2022.06.30
29A00217Dwarf BoasHatched2022.07.01
30A00218PseudoxyrhophiidsHatched2022.07.02
31A00249LamprophiidsSold2022.07.29
32A00250HomalopsidsHatched2022.07.31
33A00251Asian Pipe Hatched2022.07.31
34A00252ElapidsHatched2022.08.01
35A00253BoasHatched2022.08.01
36A00254Splitjaw Hatched2022.08.02
37A00283PseudoxyrhophiidsHatched2022.08.27
38A00284PythonsHatched2022.08.27
39A00285PseudaspididsHatched2022.08.28
40A00286Shovel-Snout Hatched2022.08.29
41A00287PsammophiidsSold2022.08.29
42A00288Snail-Eating Hatched2022.08.30
43A00289ElapidsHatched2022.09.01
44A00290HomalopsidsHatched2022.09.01
45A00291LamprophiidsHatched2022.09.01
46A00292Mexican BurrowingHatched2022.09.01
SPECIE
 
Upvote 0
I've had a look over it and found a couple of mistakes in my logic, hopefully I have corrected all of them.
VBA Code: 
Option Explicit
Sub DATE2SHEET()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    Dim lrow As Long, c As Range, rCopy As Range
    
    With Worksheets("SPECIE")
        Set rCopy = .Range("A1:D1")
        lrow = .Range("A" & Rows.Count).End(xlUp).Row
        
        For Each c In .Range("D2:D" & lrow)
            Set rCopy = Union(rCopy, c.Offset(, -3).Resize(, 4))
        
            If Format(c.Value, "MMM-YY") <> Format(c.Offset(1), "MMM-YY") Then
                
                With Sheets.Add(, Sheets(Sheets.Count))
                    .Name = Format(c.Value, "MMM-YY")
                
                    rCopy.Copy .Range("A1")
                    .Columns.AutoFit
                End With
                Set rCopy = .Range("A1:D1")

            End If
        Next
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
    MsgBox " >>> Processed Complete! <<< ", vbInformation + vbOKOnly

End Sub     '   END OF MODULE DATE2SHEET()
 
Upvote 0
Solution
jasonb75 said:
I've had a look over it and found a couple of mistakes in my logic, hopefully I have corrected all of them.
VBA Code: 
Option Explicit
Sub DATE2SHEET()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    Dim lrow As Long, c As Range, rCopy As Range
   
    With Worksheets("SPECIE")
        Set rCopy = .Range("A1:D1")
        lrow = .Range("A" & Rows.Count).End(xlUp).Row
       
        For Each c In .Range("D2:D" & lrow)
            Set rCopy = Union(rCopy, c.Offset(, -3).Resize(, 4))
       
            If Format(c.Value, "MMM-YY") <> Format(c.Offset(1), "MMM-YY") Then
               
                With Sheets.Add(, Sheets(Sheets.Count))
                    .Name = Format(c.Value, "MMM-YY")
               
                    rCopy.Copy .Range("A1")
                    .Columns.AutoFit
                End With
                Set rCopy = .Range("A1:D1")

            End If
        Next
    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
   
    MsgBox " >>> Processed Complete! <<< ", vbInformation + vbOKOnly

End Sub     '   END OF MODULE DATE2SHEET()
Click to expand...
sorry mate will try it our later, down with a weeklong cold :(
 
Upvote 0
again a positive news after my cold and the super typhoon that hit our country.
Thanks Mate! Always :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

Keebler
  • Solved
new project: copy range without empty or blank rows
5 6 7
Replies
68
Views
1K
Keebler
Keebler
N
  • Solved
Copy/paste a row from within a loop, before that loop moves on to next cell
Replies
5
Views
225
Joe4
Joe4
tabbytomo
  • Solved
Copy entire row if cell has specific value, looking at multiple columns and worksheets.
Replies
2
Views
280
NateSC
NateSC
B
  • Question
Copy formula into a cell using vba
2
Replies
11
Views
417
BobtBuilder
B
E
  • Solved
Copying data from 1 sheet to another in vba
Replies
7
Views
174
Kaper
Kaper

Forum statistics

Threads
1,214,606
Messages
6,120,488
Members
448,967
Latest member
visheshkotha

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top