Posts by xladept

Sub DeleteRowsPWill() 'KjBox - Ozgrid
    Dim x, y, z, i As Long, ii As Long
    y = Array("Sarah", "David", "Tom", "Bethany", "John", "Katie")
    z = Array(0, 1, -1, 2, -2, 3)
     
    With ActiveSheet.UsedRange
        x = .Value
        For i = 2 To UBound(x, 1)
            ii = Application.Match(x(i, 1), y, 0) - 1
            If x(i, 5) = z(ii) Then x(i, 1) = ""
        Next
        .Value = x
        .Columns(1).SpecialCells(4).EntireRow.Delete
    End With
     
End Sub

Sub Category_in_Data(rArray() As Variant)
    
    'Initiated just for EQUALS (excl. Contains, starting with), to test if it works (it doesn't)
    'x - rows,     y - columns dimensions
    
    Dim x As Long, y As Integer, hdrValue As String, strValue As String   'strings for alternative test
    Dim dataTbl As ListObject                'table on data sheet
    Dim dCol As Integer, dRow As Long        'data table header column, data row
    Dim dRNG As Range, bMatch As Boolean
    Dim dCAT As Range
    
    Set dataTbl = Sheet1.ListObjects(1)
    Set dRNG = dataTbl.DataBodyRange
    
    For dRow = 1 To dRNG.Rows.Count
        For x = 3 To UBound(rArray, 1)    'LookUP_ref; start at row 4
            For y = 2 To UBound(rArray, 2)   'LookUP_ref; start at column C
                If rArray(x, y) <> "" Then
                    '***************************************************************************************
                    ' Here's the problem. It overwrites ABC to JKL because it fulfills the criteria later on
                    '    and it's not possible to stack ANDs after each loop within a row
                    '***************************************************************************************
                   
                    dCol = dataTbl.HeaderRowRange.Find(CStr(rArray(1, y))).Column    'data table column position
                    
                    If dRNG(dRow, dCol).Value = rArray(x, y) Then
                        bMatch = True
                    End If
                    
                    If bMatch = False Then
                        Exit For
                    Else
                    Set dCAT = dRNG(dRow, dCol).Offset(, 50).End(xlToLeft)
                     If dCAT.Value = "" Then dCAT.Value = rArray(x, 1)
                    End If
                    
                    bMatch = False
                    '***********************************************
                    
                'Alternative TEST - to stack ANDs after each loop within row on ref sheet
                'type mismatch - probably expects a boolean, not string


'                strValue = strValue And CStr(rArray(x, y))
'                hdrValue = hdrValue And CStr(rArray(1, y))
                'Debug.Print strValue, hdrValue
                
                End If
            Next y
    
        Next x
    Next dRow
End Sub

Sub Pulsar(): Dim IT As String, SG As String, LC As String, GP As String
Dim wr As Worksheet, wd As Worksheet, r As Long, d As Long, CAT As String
        Set wr = Sheets("lookup_ref"): Set wd = Sheets("data")
For r = 4 To wr.Range("F" & Rows.count).End(xlUp).Row
                IT = wr.Cells(r, 3):  GP = wr.Cells(r, 6)
    If wr.Cells(r, 5) <> "" Then LC = "*" & wr.Cells(r, 5) & "*" Else LC = ""
    If wr.Cells(r, 4) <> "" Then SG = "*" & wr.Cells(r, 4) & "*" Else SG = ""


        For d = 3 To wd.Range("B" & Rows.count).End(xlUp).Row: CAT = wd.Cells(d, 8)
        If wd.Cells(d, 4) = IT And wd.Cells(d, 3) Like SG And _
        wd.Cells(d, 5) Like LC And wd.Cells(d, 2) = GP Then
                    GoSub RetCat: GoTo GetNext
        ElseIf wd.Cells(d, 4) = IT And _
        wd.Cells(d, 5) Like LC And wd.Cells(d, 2) = GP Then
                    GoSub RetCat: GoTo GetNext
        [B][COLOR=#ff0000]ElseIf wd.Cells(d, 5) Like LC And wd.Cells(d, 2) = GP Then
                    GoSub RetCat: GoTo GetNext[/COLOR][/B]
        End If: Next d
GetNext:        Next r: Exit Sub
RetCat: wr.Cells(r, 2) = CAT: CAT = "": Return
End Sub

Sub DrawLine(FromCell As Range, ToCell As Range)
Dim Bx As Single, By As Single, Ex As Single, Ey As Single


Bx = FromCell.Left + FromCell.Width / 2
By = FromCell.Top + FromCell.Height / 2
Ex = ToCell.Left + ToCell.Width / 2
Ey = ToCell.Top + ToCell.Height / 2


    'FromCell.Parent.Shapes.AddConnector(msoConnectorStraight, Bx, By, Ex, Ey).Select
                FromCell.Parent.Shapes.AddLine(Bx, By, Ex, Ey).Select
     
End Sub

Sub LoopAllExcelFilesInFolderVer()
     'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
     'SOURCE: [URL="http://www.TheSpreadsheetGuru.com"]www.TheSpreadsheetGuru.com[/URL]
     
     'Optimize Macro Speed
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
     'Retrieve Target Folder Path From User
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With
     'In Case of Cancel
NextCode:
    myPath = myPath
    If myPath = "" Then GoTo ResetSettings
     'Target File Extension (must include wildcard "*")
    myExtension = "*.xls"
     'Target Path with Ending Extention
     
    [B][COLOR=#ff0000]Dim F As String, n As Long, b As Long: b = 200901
 
'Loop through each Excel file in folder
Do: F = Left(b, 4) & "-" & Right(b, 2)
If Len(Dir(myPath & F & myExtension, vbDirectory)) <> 0 Then
        myFile = F & myExtension[/COLOR][/B]
        
         'Set variable equal to opened workbook
        Set wb = Workbooks.Open(Filename:=myPath & myFile)
         'copy/paste info
        With wb.Worksheets(11)
            .Select
            .Cells.Find(What:="Sao Paulo Faria Lima", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
             
            .Range(Selection, Selection.End(xlDown)).Select
             
            .Range(Selection, Selection.End(xlToRight)).Select
             
            Set myCells = Selection
            myCells.Select
            Selection.Copy
                         
        End With
         
         'dont change name of workbook
        Windows("Macro.xlsm").Activate
        Range("A10000").Select
        Selection.End(xlUp).Offset(2, 0).Select
        ActiveSheet.Paste
         
        Application.CutCopyMode = False
         
         'Save and Close Workbook
        wb.Close SaveChanges:=True
         'Get next file name


        [B][COLOR=#ff0000]n = n + 1
        If n Mod 12 = 0 Then
        b = Left(b, 4) + 1 & "01"
        Else: b = b + 1: End If
        End If: Loop Until n > 100[/COLOR][/B]
     
     'Date each section
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "1/1/2009"
    Set rng = Selection
    Do
        On Error GoTo Error_handler
        Selection.End(xlDown).Select
        Selection.End(xlDown).Offset(1).Select
        ActiveCell.FormulaR1C1 = DateAdd("m", 1, rng.Value)
        Set rng = Selection
    Loop
Error_handler:
     'Message Box when tasks are completed
    MsgBox "Task Complete!"
ResetSettings:
     'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
End Sub