joeny0706

02-18-2019, 01:15 PM

Hi All

I have 9 VBA Modules I am trying to join. I have alreadyjoined a bunch and it is working but I have one that has a “Private Function”state meant after it and it is not working out the same. Can anyone help mewith joining these.

Currently I have a module I call runall. Then it just callsall of them. But when I will need to load this on other computers it willrequire me to import all 9 modules. Would be easier if it is all in one.

When I joined others, I just removed the DIM statements andthe End Sub and they worked. Below I put some of the ones I need joined. It isthe negative module with the private function it keeps stopping at.

Thanks

------------------------------------------------------------------------------------------------------------------------------------------

Sub RenameActivesheet1()

ActiveSheet.Name ="Input"

End Sub

------------------------------------------------------------------------------------------------------------------------------------------

Sub addClassReturns()

Dim sht As Worksheet

Dim Where As Range

For Each sht InWorksheets

With sht

Set Where =.Range("C" & .Rows.Count).End(xlUp)

Set Where =.Range("J1", .Range("J" & Where.Row))

End With

Withsht.Range("J1")

.FormulaR1C1 = _

"=IF(LEFT(RC[-7],1)=""1"",""2 RouteReturns"", IF(LEFT(RC[-7],1)=""5"",""2Route Returns"",IF(LEFT(RC[-7],1)=""4"",""2Route Returns"", """")))"

IfWhere.Rows.Count > 1 Then

.AutoFillDestination:=Where, Type:=xlFillDefault

End If

End With

Next

End Sub

------------------------------------------------------------------------------------------------------------------------------------------

Sub Negative()

Dim Ws As Worksheet

Dim Where As Range,This As Range

For Each Ws InWorksheets

Set Where =SpecialCells(Ws.UsedRange, xlCellTypeConstants, xlNumbers)

If Not Where IsNothing Then

For Each This InWhere

If This < 0Then This = Abs(This)

Next

End If

Next

End Sub

Private Function SpecialCells(ByVal r As Range, ByVal Typ AsXlCellType, _

Optional ByValValue As XlSpecialCellsValue = &H17) As Range

'Avoid theSpecialCells-BUG to return all cells from the current region

On Error Resume Next

Select Case Typ

CasexlCellTypeConstants, xlCellTypeFormulas

Set SpecialCells= Intersect(r, r.SpecialCells(Typ, Value))

CasexlCellTypeConstants Or xlCellTypeFormulas

'Specialfeature: Return all used cells

Set SpecialCells= Intersect(r, r.SpecialCells(xlCellTypeConstants, Value))

If SpecialCellsIs Nothing Then

SetSpecialCells = Intersect(r, r.SpecialCells(xlCellTypeFormulas, Value))

Else

SetSpecialCells = Union(SpecialCells, Intersect(r,r.SpecialCells(xlCellTypeFormulas, Value)))

End If

Case Else

Set SpecialCells= Intersect(r, r.SpecialCells(Typ))

End Select

End Function

------------------------------------------------------------------------------------------------------------------------------------------

Sub Template()

Dim DataJ, DataK

Dim Where As Range

Dim i As Long

Dim Ws As Worksheet

For Each Ws InWorksheets

With Ws

Set Where =.Range("J1", .Range("J" & .Rows.Count).End(xlUp))

End With

DataJ =Where.Value

DataK =Where.Offset(, 1).Value

If NotIsArray(DataJ) Then

ReDim DataJ(1 To1, 1 To 1)

DataJ(1, 1) =Where.Value

ReDim DataK(1 To1, 1 To 1)

DataK(1, 1) =Where.Offset(, 1).Value

End If

For i = 1 ToUBound(DataJ)

If NotIsError(DataJ(i, 1)) Then

Select CaseLeft$(Trim$(DataJ(i, 1)), 1)

Case"1"

DataK(i,1) = "Copy of: Intuit Service Invoice"

Case"2"

DataK(i,1) = "Custom Credit Memo"

End Select

End If

Next

Where.Offset(,1).Value = DataK

Next

End Sub

------------------------------------------------------------------------------------------------------------------------------------------

Option Explicit

Sub AddDiscountReturns()

Dim wbItem AsWorkbook

Dim wsInput AsWorksheet

Dim rData AsRange, rData1 As Range, rLast As Range, rTemp As Range

Dim iRow As Long,iItem As Long

Dim dDiscount AsDouble

Dim vItems AsVariant, vPrices As Variant

Application.ScreenUpdating = False

'get normal prices

Workbooks.Add"C:\midstate\item prices.xlsx" ' <<<<<<<<<<<<< change WB path

Set wbItem =ActiveWorkbook

Set rTemp =wbItem.Worksheets("Sheet1").Range("C1")

Set rTemp = Range(rTemp,rTemp.End(xlDown))

vItems =Application.WorksheetFunction.Transpose(rTemp)

Set rTemp =wbItem.Worksheets("Sheet1").Range("E1")

Set rTemp =Range(rTemp, rTemp.End(xlDown))

vPrices =Application.WorksheetFunction.Transpose(rTemp)

wbItem.Close False

'set data

Set wsInput =Worksheets("Input") ' <<<<< Change WSname

Set rLast =wsInput.Cells(1, wsInput.Columns.Count).End(xlToLeft)

Set rData =Range(wsInput.Cells(1, 1), rLast).EntireColumn

Set rData =Intersect(rData, wsInput.Cells(1, 1).CurrentRegion.EntireRow)

Set rData1 =rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)

'add Normal Prices

With wsInput

.Cells(1,8).Value = "Discount Price"

.Cells(1,9).Value = "line class"

For iRow = 2To rData.Rows.Count

iItem = 0

On ErrorResume Next

iItem =Application.WorksheetFunction.Match(.Cells(iRow, 4).Value, vItems, 0)

On ErrorGoTo 0

If iItem> 0 Then .Cells(iRow, 7).Value = vPrices(iItem)

Next iRow

End With

'sort by invoicedata and invoice number

With wsInput.Sort

.SortFields.Clear

.SortFields.Add Key:=rData1.Columns(1), SortOn:=xlSortOnValues,Order:=xlAscending, DataOption:=xlSortNormal

.SortFields.Add2 Key:=rData1.Columns(2), SortOn:=xlSortOnValues,Order:=xlAscending, DataOption:=xlSortNormal

.SetRangerData

.Header =xlYes

.MatchCase =False

.Orientation =xlTopToBottom

.SortMethod =xlPinYin

.Apply

End With

'go up and add"20 Sales & Discount" to col D after invoice change

With wsInput

For iRow =rData.Rows.Count To 2 Step -1

If.Cells(iRow + 1, 2).Value <> .Cells(iRow, 2).Value Then

.Rows(iRow + 1).Insert

.Cells(iRow + 1, 4).Value = "20* Discounts"

.Cells(iRow + 1, 9).Value = "2.5 Sales Promotional Discount"

End If

Next iRow

End With

'go down and calcdiscount and fill in data

dDiscount = 0#

With wsInput

Set rData =.Cells(1, 1).CurrentRegion

For iRow = 2To rData.Rows.Count

IfLen(.Cells(iRow, 1).Value) > 0 Then

dDiscount = dDiscount + .Cells(iRow, 5).Value * (.Cells(iRow, 7).Value -.Cells(iRow, 6).Value)

Else

.Cells(iRow, 1).Value = .Cells(iRow - 1, 1).Value

.Cells(iRow, 2).Value = .Cells(iRow - 1, 2).Value

.Cells(iRow, 3).Value = .Cells(iRow - 1, 3).Value

.Cells(iRow, 8).Value = dDiscount

dDiscount = 0#

End If

Next iRow

End With

'cleanup

Application.ScreenUpdating = True

End Sub

------------------------------------------------------------------------------------------------------------------------------------------

Sub AddRow1()

WithWorksheets("Input")

.Range("A1").Value = "Invoice Date"

.Range("B1").Value = "Invoice Number"

.Range("C1").Value = "Account Name"

.Range("D1").Value = "Item"

.Range("E1").Value = "Qty"

.Range("H1").Value = "Discount Price"

.Range("I1").Value = "line class"

.Range("J1").Value = "class"

.Range("K1").Value = "template"

End With

End Sub

-----------------------------------------------------------------------------------------

I have attached all of the ones I need if anyone wants to help or just try to explain what I need to do with the private function. But I need them in order

Rename worksheet

Replace item returns

replaceCusName

budway

AddClassReturns

ConvertNegtoPos

AddTemplete

AddDiscountReturns

AddRowOne

I have 9 VBA Modules I am trying to join. I have alreadyjoined a bunch and it is working but I have one that has a “Private Function”state meant after it and it is not working out the same. Can anyone help mewith joining these.

Currently I have a module I call runall. Then it just callsall of them. But when I will need to load this on other computers it willrequire me to import all 9 modules. Would be easier if it is all in one.

When I joined others, I just removed the DIM statements andthe End Sub and they worked. Below I put some of the ones I need joined. It isthe negative module with the private function it keeps stopping at.

Thanks

------------------------------------------------------------------------------------------------------------------------------------------

Sub RenameActivesheet1()

ActiveSheet.Name ="Input"

End Sub

------------------------------------------------------------------------------------------------------------------------------------------

Sub addClassReturns()

Dim sht As Worksheet

Dim Where As Range

For Each sht InWorksheets

With sht

Set Where =.Range("C" & .Rows.Count).End(xlUp)

Set Where =.Range("J1", .Range("J" & Where.Row))

End With

Withsht.Range("J1")

.FormulaR1C1 = _

"=IF(LEFT(RC[-7],1)=""1"",""2 RouteReturns"", IF(LEFT(RC[-7],1)=""5"",""2Route Returns"",IF(LEFT(RC[-7],1)=""4"",""2Route Returns"", """")))"

IfWhere.Rows.Count > 1 Then

.AutoFillDestination:=Where, Type:=xlFillDefault

End If

End With

Next

End Sub

------------------------------------------------------------------------------------------------------------------------------------------

Sub Negative()

Dim Ws As Worksheet

Dim Where As Range,This As Range

For Each Ws InWorksheets

Set Where =SpecialCells(Ws.UsedRange, xlCellTypeConstants, xlNumbers)

If Not Where IsNothing Then

For Each This InWhere

If This < 0Then This = Abs(This)

Next

End If

Next

End Sub

Private Function SpecialCells(ByVal r As Range, ByVal Typ AsXlCellType, _

Optional ByValValue As XlSpecialCellsValue = &H17) As Range

'Avoid theSpecialCells-BUG to return all cells from the current region

On Error Resume Next

Select Case Typ

CasexlCellTypeConstants, xlCellTypeFormulas

Set SpecialCells= Intersect(r, r.SpecialCells(Typ, Value))

CasexlCellTypeConstants Or xlCellTypeFormulas

'Specialfeature: Return all used cells

Set SpecialCells= Intersect(r, r.SpecialCells(xlCellTypeConstants, Value))

If SpecialCellsIs Nothing Then

SetSpecialCells = Intersect(r, r.SpecialCells(xlCellTypeFormulas, Value))

Else

SetSpecialCells = Union(SpecialCells, Intersect(r,r.SpecialCells(xlCellTypeFormulas, Value)))

End If

Case Else

Set SpecialCells= Intersect(r, r.SpecialCells(Typ))

End Select

End Function

------------------------------------------------------------------------------------------------------------------------------------------

Sub Template()

Dim DataJ, DataK

Dim Where As Range

Dim i As Long

Dim Ws As Worksheet

For Each Ws InWorksheets

With Ws

Set Where =.Range("J1", .Range("J" & .Rows.Count).End(xlUp))

End With

DataJ =Where.Value

DataK =Where.Offset(, 1).Value

If NotIsArray(DataJ) Then

ReDim DataJ(1 To1, 1 To 1)

DataJ(1, 1) =Where.Value

ReDim DataK(1 To1, 1 To 1)

DataK(1, 1) =Where.Offset(, 1).Value

End If

For i = 1 ToUBound(DataJ)

If NotIsError(DataJ(i, 1)) Then

Select CaseLeft$(Trim$(DataJ(i, 1)), 1)

Case"1"

DataK(i,1) = "Copy of: Intuit Service Invoice"

Case"2"

DataK(i,1) = "Custom Credit Memo"

End Select

End If

Next

Where.Offset(,1).Value = DataK

Next

End Sub

------------------------------------------------------------------------------------------------------------------------------------------

Option Explicit

Sub AddDiscountReturns()

Dim wbItem AsWorkbook

Dim wsInput AsWorksheet

Dim rData AsRange, rData1 As Range, rLast As Range, rTemp As Range

Dim iRow As Long,iItem As Long

Dim dDiscount AsDouble

Dim vItems AsVariant, vPrices As Variant

Application.ScreenUpdating = False

'get normal prices

Workbooks.Add"C:\midstate\item prices.xlsx" ' <<<<<<<<<<<<< change WB path

Set wbItem =ActiveWorkbook

Set rTemp =wbItem.Worksheets("Sheet1").Range("C1")

Set rTemp = Range(rTemp,rTemp.End(xlDown))

vItems =Application.WorksheetFunction.Transpose(rTemp)

Set rTemp =wbItem.Worksheets("Sheet1").Range("E1")

Set rTemp =Range(rTemp, rTemp.End(xlDown))

vPrices =Application.WorksheetFunction.Transpose(rTemp)

wbItem.Close False

'set data

Set wsInput =Worksheets("Input") ' <<<<< Change WSname

Set rLast =wsInput.Cells(1, wsInput.Columns.Count).End(xlToLeft)

Set rData =Range(wsInput.Cells(1, 1), rLast).EntireColumn

Set rData =Intersect(rData, wsInput.Cells(1, 1).CurrentRegion.EntireRow)

Set rData1 =rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)

'add Normal Prices

With wsInput

.Cells(1,8).Value = "Discount Price"

.Cells(1,9).Value = "line class"

For iRow = 2To rData.Rows.Count

iItem = 0

On ErrorResume Next

iItem =Application.WorksheetFunction.Match(.Cells(iRow, 4).Value, vItems, 0)

On ErrorGoTo 0

If iItem> 0 Then .Cells(iRow, 7).Value = vPrices(iItem)

Next iRow

End With

'sort by invoicedata and invoice number

With wsInput.Sort

.SortFields.Clear

.SortFields.Add Key:=rData1.Columns(1), SortOn:=xlSortOnValues,Order:=xlAscending, DataOption:=xlSortNormal

.SortFields.Add2 Key:=rData1.Columns(2), SortOn:=xlSortOnValues,Order:=xlAscending, DataOption:=xlSortNormal

.SetRangerData

.Header =xlYes

.MatchCase =False

.Orientation =xlTopToBottom

.SortMethod =xlPinYin

.Apply

End With

'go up and add"20 Sales & Discount" to col D after invoice change

With wsInput

For iRow =rData.Rows.Count To 2 Step -1

If.Cells(iRow + 1, 2).Value <> .Cells(iRow, 2).Value Then

.Rows(iRow + 1).Insert

.Cells(iRow + 1, 4).Value = "20* Discounts"

.Cells(iRow + 1, 9).Value = "2.5 Sales Promotional Discount"

End If

Next iRow

End With

'go down and calcdiscount and fill in data

dDiscount = 0#

With wsInput

Set rData =.Cells(1, 1).CurrentRegion

For iRow = 2To rData.Rows.Count

IfLen(.Cells(iRow, 1).Value) > 0 Then

dDiscount = dDiscount + .Cells(iRow, 5).Value * (.Cells(iRow, 7).Value -.Cells(iRow, 6).Value)

Else

.Cells(iRow, 1).Value = .Cells(iRow - 1, 1).Value

.Cells(iRow, 2).Value = .Cells(iRow - 1, 2).Value

.Cells(iRow, 3).Value = .Cells(iRow - 1, 3).Value

.Cells(iRow, 8).Value = dDiscount

dDiscount = 0#

End If

Next iRow

End With

'cleanup

Application.ScreenUpdating = True

End Sub

------------------------------------------------------------------------------------------------------------------------------------------

Sub AddRow1()

WithWorksheets("Input")

.Range("A1").Value = "Invoice Date"

.Range("B1").Value = "Invoice Number"

.Range("C1").Value = "Account Name"

.Range("D1").Value = "Item"

.Range("E1").Value = "Qty"

.Range("H1").Value = "Discount Price"

.Range("I1").Value = "line class"

.Range("J1").Value = "class"

.Range("K1").Value = "template"

End With

End Sub

-----------------------------------------------------------------------------------------

I have attached all of the ones I need if anyone wants to help or just try to explain what I need to do with the private function. But I need them in order

Rename worksheet

Replace item returns

replaceCusName

budway

AddClassReturns

ConvertNegtoPos

AddTemplete

AddDiscountReturns

AddRowOne