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
Reply With Quote
