Need help with Macro.. its duplicating

T

tygrl510

Board Regular
Joined
Feb 9, 2009
Messages
54
hi,

I have this macro:
ub MoveData()
Dim LR As Long, LR2 As Long, LC As Long, Ctr As Long, NR As Long, ToMove As Long, RptLR As Long
Dim wks As Worksheet
Application.ScreenUpdating = False
Sheets(1).Select
On Error Resume Next
Sheets("Report").Select
If Err Then Worksheets.Add.Name = "Report"
On Error GoTo 0
With Sheets("Report")
.Range("A1").Resize(, 11).Value = [{"DIV","Line","Region","Area","SubArea","CountryCode","Country","Channel","TXN CUR","Type","Value"}]
RptLR = .Cells(Rows.Count, 1).End(xlUp).Row
If RptLR > 1 Then
.Range("A2:AC" & RptLR).ClearContents
End If
End With
For Each wks In ThisWorkbook.Worksheets
If wks.Name<> "Instructions" And wks.Name<> "Report" Then
With wks
.Select
LC = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
LR = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(1, LC + 2).Resize(, 11).Value = [{"DIV","Line","Region","Area","SubArea","CountryCode","Country","Channel","TXN CUR","Type","Value"}]
ToMove = LC - 1
For Ctr = 2 To LR Step 1
NR = .Cells(Rows.Count, LC + 2).End(xlUp).Row
.Range("A" & Ctr).Copy .Range(Cells(NR + 1, LC + 2), Cells(NR + ToMove - 8, LC + 2))
.Range("B" & Ctr).Copy .Range(Cells(NR + 1, LC + 3), Cells(NR + ToMove - 8, LC + 3))
.Range("C" & Ctr).Copy .Range(Cells(NR + 1, LC + 4), Cells(NR + ToMove - 8, LC + 4))
.Range("D" & Ctr).Copy .Range(Cells(NR + 1, LC + 5), Cells(NR + ToMove - 8, LC + 5))
.Range("E" & Ctr).Copy .Range(Cells(NR + 1, LC + 6), Cells(NR + ToMove - 8, LC + 6))
.Range("F" & Ctr).Copy .Range(Cells(NR + 1, LC + 7), Cells(NR + ToMove - 8, LC + 7))
.Range("G" & Ctr).Copy .Range(Cells(NR + 1, LC + 8), Cells(NR + ToMove - 8, LC + 8))
.Range("H" & Ctr).Copy .Range(Cells(NR + 1, LC + 9), Cells(NR + ToMove - 8, LC + 9))
.Range("I" & Ctr).Copy .Range(Cells(NR + 1, LC + 10), Cells(NR + ToMove - 8, LC + 10))
.Range(Cells(1, 10), Cells(1, LC)).Copy
With .Cells(NR + 1, LC + 11)
.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
.Range(Cells(Ctr, 10), Cells(Ctr, LC)).Copy
With .Cells(NR + 1, LC + 12)
.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
Next Ctr
LR2 = .Cells(Rows.Count, LC + 2).End(xlUp).Row
RptLR = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row
.Range(Cells(2, LC + 2), Cells(LR2, LC + 12)).Copy Sheets("Report").Range("A" & RptLR + 1)
.Range(Cells(1, LC + 2), Cells(LR2, LC + 100)).ClearContents
.Range("A1").Select
Application.CutCopyMode = False
End With
End If
Next wks
Sheets("Report").Select
RptLR = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:AC" & RptLR).Columns.AutoFit
Range("K1").Select
Application.ScreenUpdating = True

End Sub

when I run it, it duplicates everything. I have a file with several tabs, all identical in format. I need to be able to go from:
Excel Workbook
ABCDEFGHIJKL
1Div.LineRegionAreaSub-AreaCtry. CodeCtry.CHANTXN CURApr UnitsMay UnitsJun Units
2201EMBOCHINACHINACHINACHChinaDSRMB---
3201BIPOLARCHINACHINACHINACHChinaDSRMB---
4201BIOTRAYCHINACHINACHINACHChinaDSRMB---
5201CVCCHINACHINACHINACHChinaDSRMB6,7006,8508,100
201JWIC
#VALUE!
Excel 2007

Basically I need to take a horizontal table and make it pivotable. Can anyone edit the macro? It worked before, but for some reason it doesn't now.

Thanks in advance for your help!
Rio
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
I can't help you with this problem, but I can recommend using code tags so people can read the macro more easily.

Code: 
 ub MoveData()
    Dim LR As Long, LR2 As Long, LC As Long, Ctr As Long, NR As Long, ToMove As Long, RptLR As Long
    Dim wks As Worksheet
    Application.ScreenUpdating = False
    Sheets(1).Select
    On Error Resume Next
    Sheets("Report").Select
    If Err Then Worksheets.Add.Name = "Report"
    On Error GoTo 0
    With Sheets("Report")
        .Range("A1").Resize(, 11).Value =  [{"DIV","Line","Region","Area","SubArea","CountryCode","Country","Channel","TXN  CUR","Type","Value"}]
        RptLR = .Cells(Rows.Count, 1).End(xlUp).Row
        If RptLR > 1 Then
            .Range("A2:AC" & RptLR).ClearContents
        End If
    End With
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name <> "Instructions" And wks.Name <> "Report" Then
            With wks
                .Select
                LC = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
                LR = .Cells(Rows.Count, 1).End(xlUp).Row
                .Cells(1, LC + 2).Resize(, 11).Value =  [{"DIV","Line","Region","Area","SubArea","CountryCode","Country","Channel","TXN  CUR","Type","Value"}]
                ToMove = LC - 1
                For Ctr = 2 To LR Step 1
                    NR = .Cells(Rows.Count, LC + 2).End(xlUp).Row
                    .Range("A" & Ctr).Copy .Range(Cells(NR + 1, LC + 2), Cells(NR + ToMove - 8, LC + 2))
                    .Range("B" & Ctr).Copy .Range(Cells(NR + 1, LC + 3), Cells(NR + ToMove - 8, LC + 3))
                    .Range("C" & Ctr).Copy .Range(Cells(NR + 1, LC + 4), Cells(NR + ToMove - 8, LC + 4))
                    .Range("D" & Ctr).Copy .Range(Cells(NR + 1, LC + 5), Cells(NR + ToMove - 8, LC + 5))
                    .Range("E" & Ctr).Copy .Range(Cells(NR + 1, LC + 6), Cells(NR + ToMove - 8, LC + 6))
                    .Range("F" & Ctr).Copy .Range(Cells(NR + 1, LC + 7), Cells(NR + ToMove - 8, LC + 7))
                    .Range("G" & Ctr).Copy .Range(Cells(NR + 1, LC + 8), Cells(NR + ToMove - 8, LC + 8))
                    .Range("H" & Ctr).Copy .Range(Cells(NR + 1, LC + 9), Cells(NR + ToMove - 8, LC + 9))
                    .Range("I" & Ctr).Copy .Range(Cells(NR + 1, LC + 10), Cells(NR + ToMove - 8, LC + 10))
                    .Range(Cells(1, 10), Cells(1, LC)).Copy
                    With .Cells(NR + 1, LC + 11)
                        .PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                    End With
                    .Range(Cells(Ctr, 10), Cells(Ctr, LC)).Copy
                    With .Cells(NR + 1, LC + 12)
                        .PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                    End With
                Next Ctr
                LR2 = .Cells(Rows.Count, LC + 2).End(xlUp).Row
                RptLR = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Row
                .Range(Cells(2, LC + 2), Cells(LR2, LC + 12)).Copy Sheets("Report").Range("A" & RptLR + 1)
                .Range(Cells(1, LC + 2), Cells(LR2, LC + 100)).ClearContents
                .Range("A1").Select
                Application.CutCopyMode = False
            End With
        End If
    Next wks
    Sheets("Report").Select
    RptLR = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A1:AC" & RptLR).Columns.AutoFit
    Range("K1").Select
    Application.ScreenUpdating = True

End Sub


use code tags (without the spaces)

[ code ]
value
[ / code ]
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Append data to master file
Replies
6
Views
352
Alex Blakenburg
A
jolivanes
  • Question Question
Get page address.
Replies
2
Views
236
jolivanes
jolivanes
S
  • Question Question
Scan Attendance
Replies
1
Views
480
Stewart11715
S
R
  • Question Question
Copy and unfilter in VBA
Replies
1
Views
183
Alex Blakenburg
A
G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
945
GarnesGambit
G

Forum statistics

Threads
1,224,586
Messages
6,179,728
Members
452,939
Latest member
WCrawford

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