VBA - Macro works in one workbook but not another

[Gintoki01]

Hi guys,

So I have this macro that transfers data from one workbook to another. It works perfectly in the original workbook I made it in but when I copy it to another workbook it will paste the transferred data several times instead of just once.

Any ideas why this would happen?

Thanks!

Option Explicit

Public Sub transformData()
      Dim i, nLastRowMe, nLastRowOut, nRecords As Long
      Dim strSheet, str As String
      Dim wbMe, wbOut As Workbook
      
     'Application.ScreenUpdating = False
 
      Set wbMe = ActiveWorkbook
      
      i = 36
      Do While (i > 16)
            If Trim(Range("B" & i)) <> "" Then
                  nLastRowMe = i
                  i = 16
            End If
            i = i - 1
      Loop
      
      If nLastRowMe <= 16 Then
            MsgBox "There are no records to be transfered!"
            Exit Sub
      End If
      nRecords = nLastRowMe - 17
      
      Set wbOut = Workbooks.Open(wbMe.Path & "/MonthlyTest.xls")
      
      strSheet = CStr(Month(wbMe.Sheets("Form").Range("P2")))
      With wbOut.Sheets(strSheet)
            .Activate
'            nLastRowOut = .Range("A500").End(xlUp).Row + 1
            i = 220
            nLastRowOut = i
            Do While (i > 41)
                  str = .Range("A" & i).Value & .Range("B" & i).Value & .Range("C" & i).Value & .Range("D" & i).Value & .Range("E" & i).Value & .Range("F" & i).Value & .Range("G" & i).Value & .Range("H" & i).Value & .Range("I" & i).Value & .Range("J" & i).Value & .Range("K" & i).Value & .Range("L" & i).Value & .Range("M" & i).Value
                  If Replace(str, 0, "") <> "" Then
                        nLastRowOut = i + 1
                        GoTo copySections
                  End If
                  i = i - 1
            Loop


copySections:
            If i = 41 Then nLastRowOut = 42
            
            wbMe.Sheets("Form").Range("K17:K36" & nLastRowMe).Copy
                  .Range("F" & nLastRowOut).PasteSpecial xlPasteValues
            wbMe.Sheets("Form").Range("K17:K36" & nLastRowMe).Copy
                  .Range("J" & nLastRowOut).PasteSpecial xlPasteValues
            wbMe.Sheets("Form").Range("Q17:Q36" & nLastRowMe).Copy
                  .Range("M" & nLastRowOut).PasteSpecial xlPasteValues
            
            nRecords = nRecords + nLastRowOut
            wbMe.Sheets("Form").Range("A4").Copy
                  .Range("A" & nLastRowOut & ":A" & nRecords).PasteSpecial xlPasteValues
                  .Range("A" & nLastRowOut & ":A" & nRecords).Font.Size = 8
            wbMe.Sheets("Form").Range("C9").Copy
                  .Range("B" & nLastRowOut & ":B" & nRecords).PasteSpecial xlPasteValues
            wbMe.Sheets("Form").Range("C11").Copy
                  .Range("C" & nLastRowOut & ":C" & nRecords).PasteSpecial xlPasteValues
            wbMe.Sheets("Form").Range("B17").Copy
                  .Range("D" & nLastRowOut & ":D" & nRecords).PasteSpecial xlPasteValues
            wbMe.Sheets("Form").Range("P3").Copy
                  .Range("E" & nLastRowOut & ":E" & nRecords).PasteSpecial xlPasteValues
      End With
      
exitHere:
      With wbOut
            '.Save
            '.Close
      End With
      
 MsgBox "Data has been transfered."
      
 Application.CutCopyMode = False
 'Application.ScreenUpdating = True
 
End Sub

 

[RoryA]

Is there any code in the workbook you're posting to?

 

[Gintoki01]

Nope. There aren't any macros in the workbook I am pasting to.

Also the workbook that I added the macro to is basically a copy of the original except its in Japanese and not English. I doubt that matters though.

 

[RoryA]

Well I can't see anything in the code, as the copying parts are not within any loops.

 

[Gintoki01]

Hmmm... I guess it has something to do with the workbook I added the macro to but I have no clue what it could be. Thanks for checking my code though RoryA