VBA to replace formulas

[t0azt]

I have a template for journal entries that I need to get into a different format. Right now I'm writing formulas that are working, but I cannot drag down so I'm thinking there might be a vba solution.

There are 6 columns, B:G, account, center, debit, credit, company, plant.

account and center must be 10 characters long (accounts are 5 characters but I add spaces to make up the difference), debit and credit are 17 characters long, and comany and plant are 3 characters each.

If there is an amount in the credit column I need it to be changed to the number and - at the end (384- for example.)

If debit AND credit are both blank or 0 I want them to be excluded.

If possible, I would like a blank line between every 4 entries.

So what I'm trying to do is extract the account with the spaces in one cell (so if the account is 10100 the cell would contain "10100 " without the quotes), lets say column I, the center in column J, and debit or credit in K, with the company and plant concatenated under the center with leading zeros.

Something like this:

	B	C	D	E	F	G	H	I	J	K
	acct	center	dr	cr	co	plant
2	11000	7	4200.6	0	1	1		11000	7	4200.6
3	10100	53102	19142.82	0	1	2			001001
4	62252	51204		3413.62	1	7		10100	53102	19142.82
5									001002
6	22582	23502	677.19	0	1	8		62252	51204	3413.62-
7	11000	7	2614.23	0	1	15			001007
8	53102	51201	0	0	1	47		22582	23502	677.19
9	22100	1		432.20	1	50			001008
10	22170	1	300.88		1	2
11	22165	1		611.31	1	51		11000	7	2614.23
12									001015
13								22100	1	432.20-
14									001050
15								22170	1	300.88
16									001002
17								22165	1	611.31-
18									001051

<tbody>
</tbody>

And so on... right now I have the following formulas

I2	=B2&REPT(" ",10-LEN(B2))
J2	=C2&REPT(" ",10-LEN(C2))
K2	=IF(D2>0,D2&REPT(" ",17-LEN(D2)),E2&"-"&REPT(" ",16-LEN(E2)))
J3	=REPT("0",3-LEN(F2))&F2&REPT("0",3-LEN(G2))&G2

<tbody>
</tbody>

Any help would be appreciated!

Thanks!

 

[sijpie]

Option Explicit


Sub ModifyTable()
    Dim vIn As Variant, vOut As Variant
    Dim lRi As Long, lRo As Long, lC As Long, UB1 As Long, UB2 As Long
    
    vIn = Range("B1").CurrentRegion.Value   '<<<<< assuming range starts in B1
    UB1 = UBound(vIn, 1)
    UB2 = UBound(vIn, 2)
    ' Make the output array large enough for the doubling of rows and the extra row every 4 input rows
    ReDim vOut(1 To UB1 * 2 + Int(UB1 / 4 + 0.5), 1 To 3)
    
    'process columns
    For lRi = 2 To UB1  'skip heading row
        'set output row
        lRo = lRo + 2
        If lRi Mod 4 = 1 Then lRo = lRo + 1 'every four rows taking account of header row
        
        For lC = 1 To UB2
            Select Case lC
                Case 1, 2   'columns B & C - fill out to length 10 with spaces
                    vOut(lRo, lC) = SpaceUp(CStr(vIn(lRi, lC)), 10)
                Case 3   'columns D - fill out to length 17 with spaces
                    If CLng(vIn(lRi, lC)) > 0 Then vOut(lRo, lC) = SpaceUp(CStr(vIn(lRi, lC)), 17)
                Case 4      'column E
                    If CLng(vIn(lRi, lC)) > 0 Then vOut(lRo, 3) = SpaceUp(CStr(vIn(lRi, lC)) & "-", 17)
                Case 5      'column F, proces column G at same time
                    vOut(lRo + 1, 2) = ZeroUp(CStr(vIn(lRi, lC)), 3) & ZeroUp(CStr(vIn(lRi, lC + 1)), 3)
            End Select
        Next lC
    Next lRi
    
    'Now output trhe output array
    '<<<<< you can do this to different sheet if wanted
    With ActiveSheet.Range("I1").Resize(UBound(vOut, 1), UBound(vOut, 2))
        .Value = vOut
    End With
End Sub

Function SpaceUp(sIn As String, iLen As Integer) As String
'Return string appended with space characters
'to specified length
    Dim lSL As Long
    
    lSL = Len(sIn)
    If lSL > iLen Then  'error check if specified length is too small
        SpaceUp = sIn
    Else
        SpaceUp = sIn & Space$(iLen - Len(sIn))
    End If
End Function

Function ZeroUp(sIn As String, iLen As Integer) As String
'Return string starting with 0 characters
'to specified length
    Dim lSL As Long
    
    lSL = Len(sIn)
    If lSL > iLen Then  'error check if specified length is too small
        ZeroUp = sIn
    Else
        ZeroUp = String$(iLen - Len(sIn), "0") & sIn
    End If
End Function

Read the comments and act on the ones with <<<<<

 

[Amelia742]

Hi,
Create VBA macro to replace formula's in cells of all sheets in workbook
For instance:

code:
Sub finandreplace()
For Each ws In ThisWorkbook.Worksheets
For i = 4 To 5
ws.Cells.Replace "=A" & i, "=" & Cells(1, i - 2).Address(0, 0), xlWhole
Next
Next
End Sub

 

[Amelia742]

Hi,
Create VBA macro to replace formula's in cells of all sheets in workbook
For instance:

code:
Sub finandreplace()
For Each ws In ThisWorkbook.Worksheets
For i = 4 To 5
ws.Cells.Replace "=A" & i, "=" & Cells(1, i - 2).Address(0, 0), xlWhole
Next
Next
End Sub

did it work?


<style type="text/css"><!--td {border: 1px solid #ccc;}br {mso-data-placement:same-cell;}--></style>Dafont Showbox Adam4adam