PLEASE, HELP!!!!!!!!

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

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.

jindon

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995
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
 

pegbol

Board Regular
Joined
Jan 7, 2005
Messages
192
.
.
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.
.
.
 

jindon

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995

ADVERTISEMENT

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
 

jindon

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995
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
 

pegbol

Board Regular
Joined
Jan 7, 2005
Messages
192

ADVERTISEMENT

.
.
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.
.
.
.
 

jindon

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995
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
 

pegbol

Board Regular
Joined
Jan 7, 2005
Messages
192
.
.
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.
.
.
 

Forum statistics

Threads
1,147,508
Messages
5,741,568
Members
423,667
Latest member
Kai_357

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
Top