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
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sort by date Sort by votes
The process looks as if it could be simplified quite a bit. Trying to figure out what the first part is doing (taking arrVa from A2, then putting it into B2) doesn't actually appear to be doing anything. Could you explain the purpose of that part please.
 
Upvote 0
I've done a re-write on the rest of your code but left the first part untouched.

This edit will add sheets for all months, not just those that have data (I can change that if desired but left it this way for now for simplicity.
I've assumed that (as with the sample) the data will be sorted in date order, if the dates are in random order then it will not work correctly.
Excel Formula: 
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

'-------------------------------------------------
' Create sheet for each month
Dim a As Long
For a = 348 To 29 Step -29
    Sheets.Add(after:=Sheets(1)).Name = Format(a, "MMMM")
Next
'-------------------------------------------------
'   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, "MMMM") <> Format(c.Offset(1), "MMMM") Then
                rCopy.Copy Sheets(Format(c.Value, "MMMM")).Range("A1")
                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
jasonb75 said:
I've done a re-write on the rest of your code but left the first part untouched.

This edit will add sheets for all months, not just those that have data (I can change that if desired but left it this way for now for simplicity.
I've assumed that (as with the sample) the data will be sorted in date order, if the dates are in random order then it will not work correctly.
Excel Formula: 
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

'-------------------------------------------------
' Create sheet for each month
Dim a As Long
For a = 348 To 29 Step -29
    Sheets.Add(after:=Sheets(1)).Name = Format(a, "MMMM")
Next
'-------------------------------------------------
'   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, "MMMM") <> Format(c.Offset(1), "MMMM") Then
                rCopy.Copy Sheets(Format(c.Value, "MMMM")).Range("A1")
                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...
:) code is actually 4 part, the first 3 do their part A ok but the problem lies in the 4th part

VBA Code: 
'-------------------------------------------------
'   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

will let you know what happen after code integration :)
 
Upvote 0
jasonb75 said:
I've done a re-write on the rest of your code but left the first part untouched.

This edit will add sheets for all months, not just those that have data (I can change that if desired but left it this way for now for simplicity.
I've assumed that (as with the sample) the data will be sorted in date order, if the dates are in random order then it will not work correctly.
Excel Formula: 
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

'-------------------------------------------------
' Create sheet for each month
Dim a As Long
For a = 348 To 29 Step -29
    Sheets.Add(after:=Sheets(1)).Name = Format(a, "MMMM")
Next
'-------------------------------------------------
'   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, "MMMM") <> Format(c.Offset(1), "MMMM") Then
                rCopy.Copy Sheets(Format(c.Value, "MMMM")).Range("A1")
                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...
code works! thanks mate, but would you care to explain these lines...

VBA Code: 
For a = 348 To 29 Step -29
    Sheets.Add(after:=Sheets(1)).name = Format(a, "MMMM")
Next

what does 348 to 29 represents and why 29 decrement?
 
Upvote 0
Not sure it you got solution or not, but I would like present a proper way that might help code faster and neater:
below is the algorithm:
1) With no loop, no dictionary (excel variable i loop from 1 to 12 to get month)
2) For each month from Jan to Dec, create sheet for each
3) Filter the main sheet then copy/paste
Hope it helps.
VBA Code: 
Option Explicit
Sub addMonth()
Dim lr&, i&, month As String
With Sheets("SPECIE")
    .AutoFilterMode = False
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    'add SPECIE to column B and month to column E (at once, no loop)
    .Range("B2:B" & lr).Value = .Range("A2:A" & lr).Value
    With .Range("E2:E" & lr)
        .Formula = "=TEXT(D2,""mmmm"")"
        .Value = .Value
    End With
    For i = 1 To 12
        month = Format("01/" & i, "mmmm") ' generate January, February,..., December
        If Not Evaluate("=ISREF(" & month & "!A1)") Then ' if sheet of month does not exists then add
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = month ' named sheet month
        End If
        Sheets(month).Activate
        ActiveSheet.Cells.Delete ' clear old data
        With .Cells(1, 1).CurrentRegion
            .AutoFilter field:=5, Criteria1:=month 'filter each month
            .Copy
            With ActiveSheet
                .Range("A1").PasteSpecial Paste:=xlValues ' paste filterred sata into sheet month
                .Columns(4).NumberFormat = "dd/mm/yyyy"
                .Columns.AutoFit
                .Range("A1").Select
            End With
            .AutoFilter
        End With
    Next
End With
End Sub
 
Upvote 0
bebo021999 said:
Not sure it you got solution or not, but I would like present a proper way that might help code faster and neater:
below is the algorithm:
1) With no loop, no dictionary (excel variable i loop from 1 to 12 to get month)
2) For each month from Jan to Dec, create sheet for each
3) Filter the main sheet then copy/paste
Hope it helps.
VBA Code: 
Option Explicit
Sub addMonth()
Dim lr&, i&, month As String
With Sheets("SPECIE")
    .AutoFilterMode = False
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    'add SPECIE to column B and month to column E (at once, no loop)
    .Range("B2:B" & lr).Value = .Range("A2:A" & lr).Value
    With .Range("E2:E" & lr)
        .Formula = "=TEXT(D2,""mmmm"")"
        .Value = .Value
    End With
    For i = 1 To 12
        month = Format("01/" & i, "mmmm") ' generate January, February,..., December
        If Not Evaluate("=ISREF(" & month & "!A1)") Then ' if sheet of month does not exists then add
            Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = month ' named sheet month
        End If
        Sheets(month).Activate
        ActiveSheet.Cells.Delete ' clear old data
        With .Cells(1, 1).CurrentRegion
            .AutoFilter field:=5, Criteria1:=month 'filter each month
            .Copy
            With ActiveSheet
                .Range("A1").PasteSpecial Paste:=xlValues ' paste filterred sata into sheet month
                .Columns(4).NumberFormat = "dd/mm/yyyy"
                .Columns.AutoFit
                .Range("A1").Select
            End With
            .AutoFilter
        End With
    Next
End With
End Sub
Click to expand...
the more option the better :) will be trying it now...
 
Upvote 0
airforceone said:
what does 348 to 29 represents and why 29 decrement?
Click to expand...
Going the other way, it's the date when you count the number of days into the year.
29 (Jan 29)
58 (Feb 27)
87 (Mar 27)
...
348 (Dec 13)

Doing the loop backwards in the code was the easiest way to add the month sheets in the correct order.
bebo021999 said:
I would like present a proper way
Click to expand...
There is no proper or improper way, different methods that produce the same result are all correct answers.
 
Upvote 0
jasonb75 said:
Going the other way, it's the date when you count the number of days into the year.
29 (Jan 29)
58 (Feb 27)
87 (Mar 27)
...
348 (Dec 13)

Doing the loop backwards in the code was the easiest way to add the month sheets in the correct order.

There is no proper or improper way, different methods that produce the same result are all correct answers.
Click to expand...
oh my got that!
just one more query mate before I marked it solved
how would I make the month dynamic? meaning say unique months is only at July so as not to create empty sheet to December? and will the code differentiate between January 2020 and January 2021? say I have a unique series of month from January 2020 to January 2021?
 
Upvote 0
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.
 
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
234
Joe4
Joe4
tabbytomo
  • Solved
Copy entire row if cell has specific value, looking at multiple columns and worksheets.
Replies
2
Views
286
NateSC
NateSC
B
  • Question
Copy formula into a cell using vba
2
Replies
11
Views
431
BobtBuilder
B
E
  • Solved
Copying data from 1 sheet to another in vba
Replies
7
Views
183
Kaper
Kaper

Forum statistics

Threads
1,214,793
Messages
6,121,614
Members
449,039
Latest member
Mbone Mathonsi

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