PLEASE, HELP!!!!!!!!

P

pegbol

Board Regular
Joined
Jan 7, 2005
Messages
192
.
.
I need via VBA code using Arrays do the next thing:
.

Sheet1:
___A________B___________C_____D___
1|............................................Year 2003
2|Cod......Account................Debit....Credit
3|.10.......Cash...........................4
4|.14.......Inventory...................10
5|.20.......Accts. Pay................................2
6|.30.......Capital...................................12
7|..............TOTAL.....................14........14


Sheet2:
___A________B___________C_____D___
1|............................................Year 2004
2|Cod......Account................Debit....Credit
3|.11.......Bank...........................6
4|.14.......Inventory....................4
5|.16.......Fixed Assts.................18
6|.20.......Accts. Pay................................5
7|.30.......Capital...................................23
8|..............TOTAL.....................28........28



Result needed.

Sheet3:
___A________B___________C_____D________E______F____
1|............................................Year 2003.............Year 2004
2|Cod......Account................Debit....Credit........Debit....Credit
3|.10.......Cash...........................4
4|.11.......Bank.........................................................6
5|.14.......Inventory...................10............................4
6|.16.......Fixed Assts...............................................18
7|.20.......Accts. Pay................................2..............................5
8|.30.......Capital...................................12............................23
9|..............TOTAL.....................14........14..............28.........28




The result in Sheet3 will use the column “Cod.” as reference for consolidation.

I would appreciate if the code let me select a range for Sheet1 and Sheet2, cause the number of accounts will be different in each case.

A last favor, the result in Sheet3 will be sorted by column “Cod.”.
Thanks for the help..
.
.
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
Hi,

not actually all the way, but almost
Code: 
Sub pleeeeease()
Dim dic As Object, a() As Variant, lastR As Long, i As Long, ii As Integer, iii As Integer
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, n As Long, x, y
Set dic = CreateObject("Scripting.Dictionary")
Set ws1 = Sheets("sheet1")
Set ws2 = Sheets("sheet2")
Set ws3 = Sheets("sheet3")
n = ws1.Range("a65536").End(xlUp).Row + ws2.Range("a65536").End(xlUp).Row - 2
ReDim a(3 To n, 1 To 7)
Application.ScreenUpdating = False
With ws1
    lastR = .Range("a65536").End(xlUp).Row
    n = lastR
        For i = 3 To lastR
            For ii = 1 To 4
                a(i, ii) = .Cells(i, ii).Value
            Next
            a(i, 7) = "ws1"
        Next
End With
With ws2
    lastR = .Range("a65536").End(xlUp).Row
    n = 4
        For i = 3 To lastR
            For ii = 1 To 2
                a(i + n, ii) = .Cells(i, ii).Value
            Next
            For iii = 3 To 4
                a(i + n, iii + 2) = .Cells(i, iii).Value
            Next
            a(i + n, 7) = "ws2"
        Next
End With
    For i = LBound(a) To UBound(a)
        If Not dic.Exists(a(i, 1)) Then
            dic.Add a(i, 1), Nothing
        End If
    Next
With ws3
    With .Cells
        .Clear
        .MergeCells = False
    End With
    With .Range("c1:d1")
        .Merge
        .Value = "Year 2003"
        .HorizontalAlignment = xlCenter
    End With
    With .Range("e1:f1")
        .Merge
        .Value = "Year 2004"
        .HorizontalAlignment = xlCenter
    End With
    ws1.Range("a2").Resize(1, 4).Copy Destination:=.Range("a2")
    .Range("c2").Resize(1, 2).Copy Destination:=.Range("e2")
    x = dic.Keys
        For i = 1 To dic.Count
            lastR = .Range("a65536").End(xlUp).Row
            .Cells(i + 2, 1).Value = x(i - 1)
        Next
        For i = 3 To lastR + 1
            For ii = LBound(a) To UBound(a)
                If a(ii, 1) = .Cells(i, 1).Value Then
                    Select Case a(ii, 7)
                        Case "ws1"
                            For iii = 2 To 4
                                .Cells(i, iii).Value = a(ii, iii)
                            Next
                        Case Else
                            .Cells(i, 2).Value = a(ii, 2)
                            For iii = 5 To 6
                                .Cells(i, iii).Value = a(ii, iii)
                            Next
                    End Select
                End If
            Next
        Next
        .Range("a3:f" & lastR + 1).Sort key1:=.Range("a3"), order1:=xlAscending
        With .Range("c" & lastR + 2)
            .FormulaR1C1 = "=sum(r3c:r[-1]c)"
            .AutoFill Destination:=ws3.Range("c" & lastR + 2 & ":f" & lastR + 2)
        End With
        With .Range("a:a,c:f")
            .ColumnWidth = 11
            .HorizontalAlignment = xlCenter
        End With
        With .Range("a1:f" & lastR + 2)
            .BorderAround Weight:=xlThin
            .Borders(xlInsideHorizontal).Weight = xlThin
            .Borders(xlInsideVertical).Weight = xlThin
        End With
        .Range("a1").Resize(1, 2).Merge
        .Range("a" & lastR + 2).Resize(1, 2).Merge
End With
Application.ScreenUpdating = True
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
Set dic = Nothing
Erase a
Erase x
End Sub
the structure of sheet1 and sheet2 MUST be the same as your sample

rgds,

jindon
 
Upvote 0
.
.
Amazing!!!. The code runs perfectly ok.

But, when I increase the number of accounts, it only consolidates until row 4 in the case of Sheet1.

So, I unpretentiously presume the problem is the next:

___________________________________________________________________

With ws2
lastR = .Range("a65536").End(xlUp).Row
n = 4 '<------------------------------------I THINK HERE IS THE PROBLEM
For i = 6 To lastR
For ii = 1 To 2
a(i + n, ii) = .Cells(i, ii).Value
Next
For iii = 3 To 4
a(i + n, iii + 2) = .Cells(i, iii).Value
Next
a(i + n, 7) = "ws2"
Next
End With
_____________________________________________________________________



Example:
For 15 accounts, I have to change: n = 15.

The question is: How can the code detect automatically the last cell with data?. So, the macro should show the consolidation with different number of accounts.
.
.
 
Upvote 0
Hi

the code reads;

With ws1
lastR = .Range("a65536").End(xlUp).Row
for the last record for the sheet1

With ws2
lastR = .Range("a65536").End(xlUp).Row
for the last record for the sheet2

means the last row of col. A for each sheet,

n is an adjustment for each 2 rows for blank and headings rows for each sheet,
so it shouldn't affect the number of records in sheet1
actually the 2nd n, n = lastR, doesn't need.

can you post your data here, if you like?

rgds.

jindon
 
Upvote 0
Hi

Yes, you are almost right!
n was the factor

Code: 
Sub pleeeeease()
Dim dic As Object, a() As Variant, lastR As Long, i As Long, ii As Integer, iii As Integer
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, n As Long, x
Set dic = CreateObject("Scripting.Dictionary")
Set ws1 = Sheets("sheet1")
Set ws2 = Sheets("sheet2")
Set ws3 = Sheets("sheet3")
n = ws1.Range("a65536").End(xlUp).Row + ws2.Range("a65536").End(xlUp).Row - 2
ReDim a(3 To n, 1 To 7)
Application.ScreenUpdating = False
With ws1
    lastR = .Range("a65536").End(xlUp).Row
        For i = 3 To lastR
            For ii = 1 To 4
                a(i, ii) = .Cells(i, ii).Value
            Next
            a(i, 7) = "ws1"
        Next
End With
With ws2
    lastR = .Range("a65536").End(xlUp).Row
    n = ws1.Range("a65536").End(xlUp).Row - 2
        For i = 3 To lastR
            For ii = 1 To 2
                a(i + n, ii) = .Cells(i, ii).Value
            Next
            For iii = 3 To 4
                a(i + n, iii + 2) = .Cells(i, iii).Value
            Next
            a(i + n, 7) = "ws2"
        Next
End With
    For i = LBound(a) To UBound(a)
        If Not dic.Exists(a(i, 1)) Then
            dic.Add a(i, 1), Nothing
        End If
    Next
With ws3
    With .Cells
        .Clear
        .MergeCells = False
    End With
    With .Range("c1:d1")
        .Merge
        .Value = "Year 2003"
        .HorizontalAlignment = xlCenter
    End With
    With .Range("e1:f1")
        .Merge
        .Value = "Year 2004"
        .HorizontalAlignment = xlCenter
    End With
    ws1.Range("a2").Resize(1, 4).Copy Destination:=.Range("a2")
    .Range("c2").Resize(1, 2).Copy Destination:=.Range("e2")
    x = dic.Keys
        For i = 1 To dic.Count
            lastR = .Range("a65536").End(xlUp).Row
            .Cells(i + 2, 1).Value = x(i - 1)
        Next
        For i = 3 To lastR + 1
            For ii = LBound(a) To UBound(a)
                If a(ii, 1) = .Cells(i, 1).Value Then
                    Select Case a(ii, 7)
                        Case "ws1"
                            For iii = 2 To 4
                                .Cells(i, iii).Value = a(ii, iii)
                            Next
                        Case Else
                            .Cells(i, 2).Value = a(ii, 2)
                            For iii = 5 To 6
                                .Cells(i, iii).Value = a(ii, iii)
                            Next
                    End Select
                End If
            Next
        Next
        .Range("a3:f" & lastR + 1).Sort key1:=.Range("a3"), order1:=xlAscending
        With .Range("c" & lastR + 2)
            .FormulaR1C1 = "=sum(r3c:r[-1]c)"
            .AutoFill Destination:=ws3.Range("c" & lastR + 2 & ":f" & lastR + 2)
        End With
        With .Range("a:a,c:f")
            .ColumnWidth = 11
            .HorizontalAlignment = xlCenter
        End With
        With .Range("a1:f" & lastR + 2)
            .BorderAround Weight:=xlThin
            .Borders(xlInsideHorizontal).Weight = xlThin
            .Borders(xlInsideVertical).Weight = xlThin
        End With
        .Range("a1").Resize(1, 2).Merge
        .Range("a" & lastR + 2).Resize(1, 2).Merge
End With
Application.ScreenUpdating = True
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
Set dic = Nothing
Erase a
Erase x
End Sub
hope OK this time, but test it hard!

best regards,

jindon
 
Upvote 0
.
.
jindon,

WOW!!!!. :eek:

Thanks for your quick reply.

Now, the code shows exactly what I want.

My complete gratitude for your great and kind assistance.

:pray:


A last favor.

I would like the code add an extra column "#" in the Sheet3 (and enumerate automatically all the accounts):

Result needed:

Sheet3:
___A___B______C_____________D_____E________F______G____
1|...................................................Year 2003.............Year 2004
2|.. #...Cod......Account................Debit....Credit........Debit....Credit
3|..1....10.......Cash...........................4
4|..2....11.......Bank.........................................................6
5|..3....14.......Inventory...................10............................4
6|..4....16.......Fixed Assts...............................................18
7|..5....20.......Accts. Pay................................2.............................5
8|..6....30.......Capital...................................12............................23
9|....................TOTAL.....................14........14...............28.........28


One more time. Thanks in advance for your nice assistance.
.
.
.
 
Upvote 0
hi,

changed
Code: 
Sub pleeeeease()
Dim dic As Object, a() As Variant, lastR As Long, i As Long, ii As Integer, iii As Integer
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, n As Long, x
Set dic = CreateObject("Scripting.Dictionary")
Set ws1 = Sheets("sheet1")
Set ws2 = Sheets("sheet2")
Set ws3 = Sheets("sheet3")
n = ws1.Range("a65536").End(xlUp).Row + ws2.Range("a65536").End(xlUp).Row - 2
ReDim a(3 To n, 1 To 7)
Application.ScreenUpdating = False
With ws1
    lastR = .Range("a65536").End(xlUp).Row
        For i = 3 To lastR
            For ii = 1 To 4
                a(i, ii) = .Cells(i, ii).Value
            Next
            a(i, 7) = "ws1"
        Next
End With
With ws2
    lastR = .Range("a65536").End(xlUp).Row
    n = ws1.Range("a65536").End(xlUp).Row - 2
        For i = 3 To lastR
            For ii = 1 To 2
                a(i + n, ii) = .Cells(i, ii).Value
            Next
            For iii = 3 To 4
                a(i + n, iii + 2) = .Cells(i, iii).Value
            Next
            a(i + n, 7) = "ws2"
        Next
End With
    For i = LBound(a) To UBound(a)
        If Not dic.Exists(a(i, 1)) Then
            dic.Add a(i, 1), Nothing
        End If
    Next
With ws3
    With .Cells
        .Clear
        .MergeCells = False
    End With
    ws1.Range("a2").Resize(1, 4).Copy Destination:=.Range("a2")
    .Range("c2").Resize(1, 2).Copy Destination:=.Range("e2")
    x = dic.Keys
        For i = 1 To dic.Count
            lastR = .Range("a65536").End(xlUp).Row
            .Cells(i + 2, 1).Value = x(i - 1)
        Next
        For i = 3 To lastR + 1
            For ii = LBound(a) To UBound(a)
                If a(ii, 1) = .Cells(i, 1).Value Then
                    Select Case a(ii, 7)
                        Case "ws1"
                            For iii = 2 To 4
                                .Cells(i, iii).Value = a(ii, iii)
                            Next
                        Case Else
                            .Cells(i, 2).Value = a(ii, 2)
                            For iii = 5 To 6
                                .Cells(i, iii).Value = a(ii, iii)
                            Next
                    End Select
                End If
            Next
        Next
        .Range("a3:f" & lastR + 1).Sort key1:=.Range("a3"), order1:=xlAscending
        With .Range("c" & lastR + 2)
            .FormulaR1C1 = "=sum(r3c:r[-1]c)"
            .AutoFill Destination:=ws3.Range("c" & lastR + 2 & ":f" & lastR + 2)
        End With
        With .Range("a:a")
            .Insert
            .HorizontalAlignment = xlCenter
        End With
        .Range("a2").Value = "#"
        .Range("a3").Value = 1
        .Range("a3").AutoFill Destination:=.Range("a3:a" & lastR + 1), Type:=xlFillSeries
    With .Range("d1:e1")
        .Merge
        .Value = "Year 2003"
        .HorizontalAlignment = xlCenter
    End With
    With .Range("f1:g1")
        .Merge
        .Value = "Year 2004"
        .HorizontalAlignment = xlCenter
    End With
        With .Range("a:c")
            .ColumnWidth = 9
            .HorizontalAlignment = xlCenter
        End With
        With .Range("d:g")
            .ColumnWidth = 11
            .HorizontalAlignment = xlCenter
        End With
        With .Range("a1:g" & lastR + 2)
            .BorderAround Weight:=xlThin
            .Borders(xlInsideHorizontal).Weight = xlThin
            .Borders(xlInsideVertical).Weight = xlThin
        End With
        .Columns("c:c").AutoFit
        .Range("a1").Resize(1, 3).Merge
        .Range("a" & lastR + 2).Resize(1, 3).Merge
End With
Application.ScreenUpdating = True
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing
Set dic = Nothing
Erase a
Erase x
End Sub

rgds,

jindon
 
Upvote 0
.
.
jindon,


You are the man!!!!. :LOL:

Please, give me your mail address via private message.

I would like to send you a present as my gratitude for your valuable assistance.

Once again, thanks so much for your kindness.

Pedro.
.
(y)
.

PS. Let me continue asking some questions in the future.
.
.
 
Upvote 0
You must log in or register to reply here.

Similar threads

megera716
  • Solved
Return one of two dates depending on (numeric) day
Replies
3
Views
180
megera716
megera716
T
  • Solved
Match, Index problem
Replies
5
Views
341
awoohaw
awoohaw
P
  • Question
Dynamic Spilled Array Formula using byrow
Replies
8
Views
197
pto160
P
K
  • Question
conditional formatting question
Replies
2
Views
145
kerm007
K
A
  • Solved
Returning a single result for a match under certain criteria
Replies
5
Views
376
ATHlaptop
A

Forum statistics

Threads
1,214,394
Messages
6,119,262
Members
448,880
Latest member
aveternik

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