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