Macro code - help!

[markster]

Hi guys

I have a problem in that I have some really large spreadsheets in the format of Sheet 1 shown below. I’m looking for some macro code to convert it easily into the format of Sheet 2 (in sheet 2 a new spreadsheet). I’m a real novice when it comes to VBA code so need something I can manipulate easily so I can change column ranges etc as need to reorder numerous sheets. I can do it manually but obviously it will take ages.

Can anyone help?
Thanks
M

Capital Ambition Financial Monitoring (Prototype).xls
	A	B	C	D	E	F
2	Sheet1-Current
3			P.Board	P.Board	M.Board	M.Board
4	Ref	OrgName	25/01/2006	27/03/2006	22/05/2006	24/07/2006
5	114	OrganisationA	20,000		20,000
6	123	OrganisationB		20,000
7	097	OrganisationC		30,000
8
9	Sheet2-RequiredOutput
10	Ref	Organisation	BoardType	Date	AmountApproved
11	114	OrganisationA	P.Board	25/01/06	20,000
12	114	OrganisationA	M.Board	22/05/06	20,000
13	123	OrganisationB	P.Board	27/03/06	20,000
14	097	OrganisationC	P.Board	27/03/06	20,000
Sheet1

 

[stanleydgromjr]

markster,

Before the macro:

Excel Workbook
	A	B	C	D	E	F
3			P.Board	P.Board	M.*Board	M.*Board
4	Ref	Org*Name	25/01/2006	27/03/2006	22/05/2006	24/07/2006
5	114	Organisation*A*	20,000		20,000
6	123	Organisation*B*		20,000
7	97	Organisation*C*		30,000
Sheet1

Excel Workbook
	A	B	C	D	E
1	Ref	Organisation	Board*Type	Date	Amount*Approved
2
3
4
5
Sheet2

After the macro:

Excel Workbook
	A	B	C	D	E
1	Ref	Organisation	Board*Type	Date	Amount*Approved
2	114	Organisation*A*	P.Board	25/01/2006	20,000
3	114	Organisation*A*	M.*Board	22/05/2006	20,000
4	123	Organisation*B*	P.Board	27/03/2006	20,000
5	97	Organisation*C*	P.Board	27/03/2006	30,000
Sheet2

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Press and hold down the 'ALT' key, and press the 'F11' key.

On the 'Insert' menu, click 'Module'.

Copy the below code, and paste it into the Module (on the right pane).

Option Explicit
Sub MoveData()
  Dim LR As Long, NR As Long, i As Long, j As Long, k As Long
  Dim rng As Range
  Dim ws1 As Worksheet, ws2 As Worksheet
  Application.ScreenUpdating = False
  Set ws1 = Sheets("Sheet1")
  Set ws2 = Sheets("Sheet2")
  NR = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
  With ws1
    .Select
    LR = .Range("B" & Rows.Count).End(xlUp).Row
    For i = 5 To LR Step 1
      Set rng = .Range("C" & i & ":F" & i)
      j = Application.WorksheetFunction.CountA(rng)
      If j <> 0 Then
        .Range("A" & i & ":B" & i).Copy ws2.Range("A" & NR & ":B" & NR + j - 1)
        For k = 3 To 6 Step 1
          If .Cells(i, k) <> "" Then
              .Range(Cells(3, k), Cells(4, k)).Copy
              With ws2.Cells(NR, 3)
                .PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
              End With
              .Cells(i, k).Copy ws2.Cells(NR, 5)
              NR = NR + 1
          End If
        Next k
      End If
    Next i
  End With
  With ws2
    .Select
    .Range("F1").Select
  End With
  Application.ScreenUpdating = True
End Sub

Then run the "MoveData" macro.


Have a great day,
Stan

 

[markster]

Thanks mate. Looking good!!!!

 

[markster]

Hi there. One thing - I provided a shortened version here but some of my data has 50 columns. I need to expand the ranges. Will try to work how how to do this myself but any help would be appreciated.

Thanks again.

M

 

[stanleydgromjr]

markster,

I was wondering if you had more columns. This would require a change to the inner loop.

See my Private Message to you (top right hand corner of MrExcel, Welcome, markster., "Your Notifications:".


Have a great day,
Stan

 

[stanleydgromjr]

markster,

Sent your workbook back with the newly updated macro.

The new "MoveData" macro will work with "varying numbers of columns and rows of source data".

Option Explicit
Sub MoveData()
  Dim LR As Long, NR As Long, i As Long, j As Long, k As Long, LC As Long
  Dim ColName As String
  Dim rng As Range
  Dim ws1 As Worksheet, ws2 As Worksheet
  Application.ScreenUpdating = False
  Set ws1 = Sheets("Sheet1")
  Set ws2 = Sheets("Sheet2")
  NR = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
  With ws1
    .Select
    LR = .Range("B" & Rows.Count).End(xlUp).Row
    LC = Cells(4, Columns.Count).End(xlToLeft).Column
    ColName = Replace(Cells(1, LC).Address(0, 0), 1, "")
    For i = 5 To LR Step 1
      Set rng = .Range("C" & i & ":" & ColName & i)
      j = Application.WorksheetFunction.CountA(rng)
      If j <> 0 Then
        .Range("A" & i & ":B" & i).Copy ws2.Range("A" & NR & ":B" & NR + j - 1)
        For k = 3 To LC Step 1
          If .Cells(i, k) <> "" Then
              .Range(Cells(3, k), Cells(4, k)).Copy
              With ws2.Cells(NR, 3)
                .PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
              End With
              .Cells(i, k).Copy ws2.Cells(NR, 5)
              NR = NR + 1
          End If
        Next k
      End If
    Next i
  End With
  With ws2
    .Select
    .Range("F1").Select
  End With
  Application.ScreenUpdating = True
End Sub

Have a great day,
Stan