vba program to detect cell value in column and copy corresponding cell value in previous column-CodePudding

im trying to make a vba code that will detect when Active balancing is on ( A value in cell ) and then copy the previous tension value, and simillarly do the same at the end of Active balancing to copy the next tension value. (see picture for more explanation).

im planing to show those values in another sheet

thanks to the help of Mr.PeterT i modified his code to do it but i couldn't succeed. thanks for you help and mentoring guys!

image of values i want to extract

Option Explicit

Sub find_balanced_cells_and_tensions()
FindWith "A"
End Sub

Sub FindWith(checkValue As Variant)
Dim destinationSheet As Worksheet
Set destinationSheet = ThisWorkbook.Sheets.Add
destinationSheet.Name = "Equilibrage.actif.info"

Dim destRow As Long
destRow = 1

Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Sheets("Equilibrage.passif")

Dim lastRow As Long
Dim lastColumn As Long
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
lastColumn = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column

Dim i As Long
Dim j As Long
For j = 1 To lastColumn
For i = 2 To lastRow

        If sourceSheet.Cells(i, j).Value = checkValue _
        & sourceSheet.Cells(i   1, j).Value = checkValue Then
        
            sourceSheet.Cells(i - 1, j - 1).Copy _
            Destination:=destinationSheet.Range("A" & destRow)
            
            destRow = destRow   1
            
        ElseIf sourceSheet.Cells(i, j).Value = checkValue _
        & sourceSheet.Cells(i   1, j).Value <> checkValue Then
        
            sourceSheet.Cells(i   1, j - 1).Copy _
            Destination:=destinationSheet.Range("B" & destRow)
            
            destRow = destRow   1
            
            Exit For 'immediately skip to the next row
         End If
         
    Next i
Next j

End Sub

CodePudding user response：

Untested but should be close.
I will test if you can share a sample dataset.

Sub find_balanced_cells_and_tensions()
    FindWith "A"
End Sub

Sub FindWith(checkValue As Variant)
    Dim sourceSheet As Worksheet
    Dim destinationSheet As Worksheet
    
    Dim destRow As Long, lastRow As Long, lastColumn As Long, valCount As Long
    Dim i As Long, j As Long, preVal, postval, cellLabel, dt, tm
    
    Set sourceSheet = ThisWorkbook.Sheets("Equilibrage.passif")
    Set destinationSheet = ThisWorkbook.Sheets.Add()
    destinationSheet.Name = "Equilibrage.actif.info"
    
    destRow = 1
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
    lastColumn = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
    
    For j = 4 To lastColumn Step 2 'only process relevant columns
        i = 3
        Do 'from 3 to lastrow-1 to allow for -1 at top and  1 at bottom
    
            If sourceSheet.Cells(i, j).Value = checkValue Then
                
                dt = sourceSheet.Cells(i - 1, 1).Value 'collect start info
                tm = sourceSheet.Cells(i - 1, 2).Value
                cellLabel = sourceSheet.Cells(1, j).Value
                preVal = sourceSheet.Cells(i - 1, j - 1).Value
                
                
                valCount = 1 'how many values in this run?
                Do While sourceSheet.Cells(i, j).Offset(valCount).Value = checkValue
                    valCount = valCount   1
                Loop
                postval = sourceSheet.Cells(i   valCount, j - 1).Value
                
                destinationSheet.Cells(destRow, 1).Resize(1, 5).Value = _
                   Array(dt, tm, cellLabel, preVal, postval)
                
                destRow = destRow   1
                i = i   valCount
            End If
            i = i   1
        Loop While i < lastRow
    Next j
End Sub

CodePudding user response：

So after countless hit and miss and the help of Tim Williams and Funthomas, i arrived to this code that does the job plus some things.

the worksheet to get the values from is this one : Value source And the result of the code is like this : Results

the final code is like this :

Option Explicit

Sub find_balanced_cells_and_tensions_A()

FindWith "A" ' we can replace A by any value we want to look for here

End Sub

Sub FindWith(checkValue As Variant)
Dim destinationSheet As Worksheet
Set destinationSheet = ThisWorkbook.Sheets.Add
destinationSheet.Name = "Equilibrage.actif.info"

'___ variables to track cells where will put our extacted values _______

Dim destRow As Long
destRow = 1
Dim destRow2 As Long
destRow2 = 1
'______ source sheet where we take our values from ___________

Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Sheets("Equilibrage.passif")

'_____ defining the end of columns and rows to end scaning for values _____________

Dim lastRow As Long
Dim lastColumn As Long
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
lastColumn = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column

Dim i As Long
Dim j As Long
For j = 1 To lastColumn
For i = 2 To lastRow

   '_____this part is to detect the start of balancing and taking the tension value of the previous row______________________
        
        If sourceSheet.Cells(i, j).Value = checkValue _
        And sourceSheet.Cells(i - 1, j).Value = 0 Then
        
            sourceSheet.Cells(i - 1, j - 1).Copy _
            Destination:=destinationSheet.Range("E" & destRow)
            Range("A" & destRow).Value = sourceSheet.Cells(1, j)
            Range("B" & destRow).Value = "was actively balanced at"
            Range("C" & destRow).Value = sourceSheet.Cells(i, 2)
            Range("D" & destRow).Value = "from"
            Range("F" & destRow).Value = "to"
            
            destRow = destRow   1
            
    '______ this condition is for when the balancing starts at the first row of the table so we take the present tension instead of the previous ___________
        
        ElseIf sourceSheet.Cells(i, j).Value = checkValue _
        And sourceSheet.Cells(i - 1, j).Value <> checkValue _
        And sourceSheet.Cells(i - 1, j).Value <> 0 Then
        
        sourceSheet.Cells(i, j - 1).Copy _
        Destination:=destinationSheet.Range("E" & destRow)
        Range("A" & destRow).Value = sourceSheet.Cells(1, j)
        Range("B" & destRow).Value = "was actively balanced at"
        Range("C" & destRow).Value = sourceSheet.Cells(i, 2)
        Range("D" & destRow).Value = "from"
        Range("F" & destRow).Value = "to"
        destRow = destRow   1
        
    End If
   '_____to find the next tension value after the end of balancing _____________
  
        If sourceSheet.Cells(i, j).Value = checkValue _
        And sourceSheet.Cells(i   1, j).Value <> checkValue _
        And IsEmpty(sourceSheet.Cells(i   1, j).Value) = False Then
        
            sourceSheet.Cells(i   1, j - 1).Copy _
            Destination:=destinationSheet.Range("G" & destRow2)
            Range("H" & destRow2).Value = "at"
            Range("I" & destRow2).Value = sourceSheet.Cells(i   1, 2)
            
            destRow2 = destRow2   1
            
    '_____in case the balancing ends at the last row we take the present tension as the next one doesnt exist _____________
        
        ElseIf sourceSheet.Cells(i, j).Value = checkValue _
        And IsEmpty(sourceSheet.Cells(i   1, j).Value) = True Then
        
        
        sourceSheet.Cells(i, j - 1).Copy _
        Destination:=destinationSheet.Range("G" & destRow2)
        Range("H" & destRow2).Value = "at"
        Range("I" & destRow2).Value = sourceSheet.Cells(i, 2)
        
        destRow2 = destRow2   1
          
            
         End If

         
    Next i
    

Next j


'_____ Cells modification and formating _________________

Range("C:C").NumberFormat = "hh:mm:ss"
Range("I:I").NumberFormat = "hh:mm:ss"
Range("E:E").Style = "Normal"
Range("G:G").Style = "Normal"

Range("A:K").Font.Size = 14
Range("E:E").Font.Bold = True
Range("G:G").Font.Bold = True
Worksheets("Equilibrage.actif.info").Columns.AutoFit

End Sub