Change specific values (not all) in a VBA sub

[juscuz419]

I am trying really hard to teach myself VBA through trial and error. I have the following that is doing exactly what I want it to do. And I'm sure there is a much better and more elegant way to do it, but it does work.
What I cannot figure out is how to change move to the next row of both the source and target worksheets for the cells shown below in bold red font. This is the first of probably many things I ultimately want this sub to do so any help will be another learning tool for me.

Sub CopyValuesBetweenWorksheets()
Dim sourceWS As Worksheet
Dim targetWS As Worksheet

' Set the source and target worksheets
Set sourceWS = ThisWorkbook.Worksheets("MRC_4699A") ' eventually replace "MRC_4699A" with the next sheet with a name LIKE {"***_*****}
Set targetWS = ThisWorkbook.Worksheets("Daily Summary") '
' Copy values from specific cells in the source sheet
targetWS.Range("B21").Value = sourceWS.Range("f4").Value
targetWS.Range("c21").Value = sourceWS.Range("m4").Value
targetWS.Range("d21").Value = sourceWS.Range("q1").Value
targetWS.Range("f21").Value = sourceWS.Range("e18").Value
targetWS.Range("g21").Value = sourceWS.Range("f18").Value
targetWS.Range("h21").Value = sourceWS.Range("g18").Value
targetWS.Range("i21").Value = sourceWS.Range("h18").Value
targetWS.Range("E21").Value = ""
If sourceWS.Range("AB3").Value Or sourceWS.Range("AB4").Value = True Then
targetWS.Range("E21").Value = "Pickup/SUV"
End If

Dim nonBlankCount1 As Long
nonBlankCount1 = Application.WorksheetFunction.Count(sourceWS.Range("K18:M18"))
targetWS.Range("k21") = nonBlankCount1

Dim nonBlankCount2 As Long
nonBlankCount2 = Application.WorksheetFunction.Count(sourceWS.Range("N18"))
targetWS.Range("L21") = nonBlankCount2
If nonBlankCount2 = 1 Then
targetWS.Range("L21") = "yes"
End If

End Sub

 

[Micron]

I don't understand the question. Maybe you want to look into .Offset property of the range or target.

Please post code within code tags (use vba button on posting toolbar) to maintain indentation and readability. That would prevent you from altering font colours though so comments in the code should work around that.

 

[CephasOz]

Some of your copies are from very different locations, making it impossible to put them in a loop, so I've only looped a few of the copies. Anyway, it should give you the idea.

Sub CopyValuesBetweenWorksheets()
    Const cstrTitle As String = "Copy Values"
    Const cstrLike As String = "[A-Z][A-Z][A-Z]_[0-9][0-9][0-9][0-9][A-Z]"
    Dim sourceWS As Worksheet
    Dim targetWS As Worksheet
    Dim loopWS As Worksheet
    Dim lngRow As Long
    Dim lngCol As Long
    Dim rngCell As Range
    '
    ' Set the source worksheet
    Set sourceWS = Nothing
    For Each loopWS In ThisWorkbook.Worksheets
        If (loopWS.Name Like cstrLike) Then
            Set sourceWS = loopWS
            Exit For
        End If
    Next
    ' Did we get a source file?
    If (sourceWS Is Nothing) Then
        MsgBox "No source file", vbExclamation + vbOKOnly, cstrTitle
    Else
        ' Set the target worksheet
        Set targetWS = ThisWorkbook.Worksheets("Daily Summary")
        With targetWS
            ' Copy values from specific cells in the source sheet
            targetWS.Range("B21").Value = sourceWS.Range("f4").Value
            targetWS.Range("c21").Value = sourceWS.Range("m4").Value
            targetWS.Range("d21").Value = sourceWS.Range("q1").Value
            '
            lngRow = 0
            For lngCol = 0 To 3  ' f21 to i21, e18 to h18
                .Range("f21").Offset(lngRow, lngCol).Value = sourceWS.Range("e18").Offset(lngRow, lngCol).Value
            Next
            '
            Set rngCell = .Range("E21")
            If (sourceWS.Range("AB3").Value Or sourceWS.Range("AB4").Value) Then
                rngCell.Value = "Pickup/SUV"
            Else
                rngCell.ClearContents
            End If
            '
            .Range("K21").Value = Application.WorksheetFunction.Count(sourceWS.Range("K18:M18"))
            '
            Set rngCell = .Range("L21")
            rngCell.Value = Application.WorksheetFunction.Count(sourceWS.Range("N18"))
            If (rngCell.Value = 1) Then
                rngCell.Value = "yes"
            End If
        End With
    End If
End Sub

 

[juscuz419]

I have code that is working for the below section of your suggested code. It does exactly what I want for a worksheet when I directly set the sourcews name. My workbook can have as many as 40 worksheets with the name LIKE "AAA_####A". I cant figure out how to SET the first worksheet name and iterate through ALL of the sheets extracting and pasteing the data that my code does.

With targetWS
' Copy values from specific cells in the source sheet
targetWS.Range("B21").Value = sourceWS.Range("f4").Value
targetWS.Range("c21").Value = sourceWS.Range("m4").Value
targetWS.Range("d21").Value = sourceWS.Range("q1").Value
'
lngRow = 0
For lngCol = 0 To 3 ' f21 to i21, e18 to h18
.Range("f21").Offset(lngRow, lngCol).Value = sourceWS.Range("e18").Offset(lngRow, lngCol).Value
Next
'
Set rngCell = .Range("E21")
If (sourceWS.Range("AB3").Value Or sourceWS.Range("AB4").Value) Then
rngCell.Value = "Pickup/SUV"
Else
rngCell.ClearContents
End If
'
.Range("K21").Value = Application.WorksheetFunction.Count(sourceWS.Range("K18:M18"))
'
Set rngCell = .Range("L21")
rngCell.Value = Application.WorksheetFunction.Count(sourceWS.Range("N18"))
If (rngCell.Value = 1) Then
rngCell.Value = "yes"
End If
End With

 

[NoSparks]

I think your first requirement here is to be able to cycle through the sheets and only deal with the ones you want.
In this thread you say

My workbook can have as many as 40 worksheets with the name LIKE "AAA_####A".

In an earlier post you said

has a name like XXX_1234A (where XXX is any three letters and 1234A is any 4 numbers followed by an A, D, or WG.

Will you please verify which you will be dealing with.

 

[juscuz419]

Up to 40 worksheets that I extract data from with a name that is LIKE "AAA_####A" where A is any letter and # is any number. I have tried everything I can think of. If I set the sourcews name to a specific name, I get the data that I want. When I try to put the code within a loop to look at each WS that matches the name pattern, I get errors OR nothing.

 

[juscuz419]

I'm going to end this thread and post a new one since this one is no longer descriptive of what I am trying to do.

 

[NoSparks]

Try this first
Based on my interpretation of things
comment out the Stop line after testing

Sub CopyValsBtwnSheets()

Dim sourceWS As Worksheet, targetWS As Worksheet, ws As Worksheet
Dim tRow As Long, sRow As Long

Set targetWS = ThisWorkbook.Worksheets("Daily Summary")

tRow = 21
sRow = 18


For Each ws In ThisWorkbook.Worksheets
    Stop    'F8 one line at a time from here while testing

    If ws.Name Like "[A-Z][A-Z][A-Z]_[0-9][0-9][0-9][0-9][A-Z]" Then
        Set sourceWS = ws
    End If
    
    If Not sourceWS Is Nothing Then
        'what to copy
        targetWS.Range("B" & tRow).Value = sourceWS.Range("f4").Value
        targetWS.Range("c" & tRow).Value = sourceWS.Range("m4").Value
        targetWS.Range("d" & tRow).Value = sourceWS.Range("q1").Value
        targetWS.Range("f" & tRow).Value = sourceWS.Range("e" & sRow).Value
        targetWS.Range("g" & tRow).Value = sourceWS.Range("f" & sRow).Value
        targetWS.Range("h" & tRow).Value = sourceWS.Range("g" & sRow).Value
        targetWS.Range("i" & tRow).Value = sourceWS.Range("h" & sRow).Value
        targetWS.Range("E" & tRow).Value = ""
        
        If sourceWS.Range("AB3").Value Or sourceWS.Range("AB4").Value = True Then
            targetWS.Range("E" & tRow).Value = "Pickup/SUV"
        End If
    
        targetWS.Range("k" & tRow) = Application.WorksheetFunction.Count(sourceWS.Range("K" & sRow).Resize(, 3))
    
        targetWS.Range("L" & tRow) = Application.WorksheetFunction.Count(sourceWS.Range("N" & sRow))
        If targetWS.Range("L" & tRow) = 1 Then targetWS.Range("L" & tRow) = "yes"
    
        tRow = tRow + 1
        sRow = sRow + 1
        Set sourceWS = Nothing
    End If
Next ws
    
End Sub

 

[CephasOz]

The code below will loop through your worksheets and process each one (if they match the pattern that you suggested). However, each one will overwrite the values of the previous one, which is obviously not what you want. Do you want the values to go down the sheet? Or do you want the values to add in some way?

Sub CopyValuesBetweenWorksheets()
    Const cstrTitle As String = "Copy Values"
    Const cstrLike As String = "[A-Z][A-Z][A-Z]_[0-9][0-9][0-9][0-9]"
    Dim sourceWS As Worksheet
    Dim targetWS As Worksheet
    Dim loopWS As Worksheet
    Dim lngRow As Long
    Dim lngCol As Long
    Dim rngCell As Range
    Dim bolFmtOK As Boolean
    '
    ' Set the target worksheet
    Set targetWS = ThisWorkbook.Worksheets("Daily Summary")
    ' Loop through the source worksheets
    Set sourceWS = Nothing
    For Each loopWS In ThisWorkbook.Worksheets
        bolFmtOK = False
        If (Left(UCase(loopWS.Name), 8) Like cstrLike) Then
            Select Case UCase(Mid(loopWS.Name, 9))
                Case "A", "D", "WG"
                    bolFmtOK = True
            End Select
        End If
        If bolFmtOK Then
            Set sourceWS = loopWS
            ' PUT YOUR PROCESSING CODE HERE
            With targetWS
                ' Copy values from specific cells in the source sheet
                targetWS.Range("B21").Value = sourceWS.Range("f4").Value
                targetWS.Range("c21").Value = sourceWS.Range("m4").Value
                targetWS.Range("d21").Value = sourceWS.Range("q1").Value
                '
                lngRow = 0
                For lngCol = 0 To 3 ' f21 to i21, e18 to h18
                    .Range("f21").Offset(lngRow, lngCol).Value = sourceWS.Range("e18").Offset(lngRow, lngCol).Value
                Next
                '
                Set rngCell = .Range("E21")
                If (sourceWS.Range("AB3").Value Or sourceWS.Range("AB4").Value) Then
                    rngCell.Value = "Pickup/SUV"
                Else
                    rngCell.ClearContents
                End If
                '
                .Range("K21").Value = Application.WorksheetFunction.Count(sourceWS.Range("K18:M18"))
                '
                Set rngCell = .Range("L21")
                rngCell.Value = Application.WorksheetFunction.Count(sourceWS.Range("N18"))
                If (rngCell.Value = 1) Then
                    rngCell.Value = "yes"
                End If
            End With
        End If
    Next loopWS
End Sub

 

[juscuz419]

Code from post 8 did not work. Code in post 9 is not what I need. Basically I am pulling info for up to three rows on each timesheet and pasting them into a summary sheet, then going to the next timesheet and getting up to three rows and pasting them into the next rows on the summary and so on until I have gone through ALL the time sheets.