Loop Copy/Paste Transpose 2 Workbooks Dynamic Date Step

[the_schuetz]

Hi everyone!

If have the following two workbooks:
(1) wrkData: which contains the first of the month in Column C and daily precipitation data starting from Column N until AR (depending on the month it goes to either AR for 31 days, AQ for 30 days, AP for 29 days and AO 28 days).

(2) wrkPrecip: which contains in Column A daily dates and in Column B I want to paste & transpose from Workbook wrkData N:AR/AQ/AP/AO in a loop.

This turns out to be more difficult than anticipated because the range that I want to copy changes from month to month. Also, sometimes I have blank cells at the end of a month in Workbook wrkData that need to stay blank in the Workbook wrkPrecip which is why I can't use the last row with data for the loop.

This is what I got so far. I do not receive an error, but as soon as I run the macro Excel stops responding. Any ideas? Thanks in advance!

'Loop copy daily data to new precipitation workbook
        
        Dim d As Long           'for loop through wrkData
        Dim p As Long           'for cell to paste into in wrkPrecip
        Dim c As Long           'defines cell step for paste in wrkPrecip
        
        wrkData.Activate
        LastRow = Cells(Rows.Count, 3).End(xlDown).Row
        
        p = 2
        
        For d = 2 To LastRow
            
            If Month(Cells(d, "C")) = 1 Or Month(Cells(d, "C")) = 3 Or Month(Cells(d, "C")) = 5 Or Month(Cells(d, "C")) = 7 Or Month(Cells(d, "C")) = 8 Or Month(Cells(d, "C")) = 10 Or Month(Cells(d, "C")) = 12 Then
            Range(Cells(d, "N"), Cells(d, "AR")).Copy
            c = 30
            
            ElseIf Month(Cells(d, "C")) = 4 Or Month(Cells(d, "C")) = 6 Or Month(Cells(d, "C")) = 9 Or Month(Cells(d, "C")) = 11 Then
            Range(Cells(d, "N"), Cells(d, "AQ")).Copy
            c = 29
            
            ElseIf Month(DateSerial(Year(Cells(d, "C")), 2, 28)) = 2 Then
            Range(Cells(d, "N"), Cells(d, "AO")).Copy
            c = 27
            
            ElseIf Month(DateSerial(Year(Cells(d, "C")), 2, 29)) = 2 Then
            Range(Cells(d, "N"), Cells(d, "AP")).Copy
            c = 28
            
            End If
                        
            wrkPrecip.Activate
            
                Cells(p, "B").PasteSpecial Transpose:=True
                p = p + c
                
            wrkData.Activate
            
            Next d

 

[DanteAmor]

Your macro has some problems.
- This line returns the total number of rows on the sheet.
LastRow = Cells(Rows.Count, 3).End(xlDown).Row
It should be:
Cells(Rows.Count, 3).End(xlUp).Row

- With this instruction you get the number of days per month:
Day(DateSerial(Year(c.Value), Month(c.Value) + 1, 1) - 1)

Try this:

Sub TranposeData()
  Dim shData As Worksheet, shPrec As Worksheet
  Dim c As Range
  Dim p As Long, n As Long
  
  Set shData = Workbooks("Work Data").Sheets(1)     'Adjust the name of the workbook
  Set shPrec = Workbooks("Work Precip").Sheets(1)   'Adjust the name of the workbook
  
  p = 2
  For Each c In shData.Range("C2", shData.Range("C" & Rows.Count).End(3))
    n = Day(DateSerial(Year(c.Value), Month(c.Value) + 1, 1) - 1) 'Days per month
    shPrec.Range("B" & p).Resize(n).Value = Application.Transpose(shData.Range("N" & c.Row).Resize(1, n).Value)
    p = p + n
  Next
End Sub

 

[the_schuetz]

Hi! Thank you so much! It works. I still have two issues - any help is appreciated:

(1) in the original data workbook (wrkData) it happens that years were skipped because no data was measured (e.g. 2021-1987 & 1981-1970 = no row for 1986-81). In the new workbook (wrkPrecip) the missing years have a row and I want these to be blank (as no data was measured). Is there a way to add this to the code?

(2) When I copy the data from wrkData to wrkPrecip I need to flip the data order around for each month. Any idea?

Thanks!

 

[DanteAmor]

Try this:

Sub TranposeData()
  Dim shData As Worksheet, shPrec As Worksheet
  Dim c As Range, f As Range
  Dim n As Long, i As Long, j As Long
  Dim endMonth As Date
  
  Set shData = Workbooks("Work Data").Sheets(1)     'Adjust the name of the workbook
  Set shPrec = Workbooks("Work Precip").Sheets(1)   'Adjust the name of the workbook
  
  For Each c In shData.Range("C2", shData.Range("C" & Rows.Count).End(3))
    endMonth = WorksheetFunction.EoMonth(c.Value, 0)
    Set f = shPrec.Range("A:A").Find(endMonth, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      n = Day(DateSerial(Year(c.Value), Month(c.Value) + 1, 1) - 1) 'Days per month
      i = f.Row
      For j = n To 1 Step -1
        shPrec.Range("B" & i).Value = shData.Cells(c.Row, Columns("M").Column + j)
        i = i + 1
      Next
    End If
  Next
End Sub

 

[the_schuetz]

Try this:

Sub TranposeData()
  Dim shData As Worksheet, shPrec As Worksheet
  Dim c As Range, f As Range
  Dim n As Long, i As Long, j As Long
  Dim endMonth As Date
 
  Set shData = Workbooks("Work Data").Sheets(1)     'Adjust the name of the workbook
  Set shPrec = Workbooks("Work Precip").Sheets(1)   'Adjust the name of the workbook
 
  For Each c In shData.Range("C2", shData.Range("C" & Rows.Count).End(3))
    endMonth = WorksheetFunction.EoMonth(c.Value, 0)
    Set f = shPrec.Range("A:A").Find(endMonth, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      n = Day(DateSerial(Year(c.Value), Month(c.Value) + 1, 1) - 1) 'Days per month
      i = f.Row
      For j = n To 1 Step -1
        shPrec.Range("B" & i).Value = shData.Cells(c.Row, Columns("M").Column + j)
        i = i + 1
      Next
    End If
  Next
End Sub

Hmm ... the code runs without errors, but it doesn't do anything. No data is copied :/ Could I add the missing rows in the original workbook (wrkData) and then run your first code?

 

[the_schuetz]

Hmm ... the code runs without errors, but it doesn't do anything. No data is copied :/ Could I add the missing rows in the original workbook (wrkData) and then run your first code?

The original workbook looks like this:

 

[DanteAmor]

Change this:
Set f = shPrec.Range("A:A").Find(endMonth, , xlValues, xlWhole, , , False)

For this:
Set f = shPrec.Range("A:A").Find(endMonth, , xlFormulas, xlWhole, , , False)

 

[the_schuetz]

Change this:
Set f = shPrec.Range("A:A").Find(endMonth, , xlValues, xlWhole, , , False)

For this:
Set f = shPrec.Range("A:A").Find(endMonth, , xlFormulas, xlWhole, , , False)

Amazing! Works perfectly! Thanks!

 

[DanteAmor]

Im glad to help you, thanks for the feedback.