Copy and paste VBA issue

[Excel_Blonde]

Hi all,

Can anyone help with the below code. I'm trying to look through all sheets across the range G4:K4 and move any data from the cells into I4. There is only 1 cell with data but it can be in any cell of the range.
It seems to work if I manually select a sheet and run the code, but doesn't automatically work across all sheets as intended. I'm sure it's something silly i'm missing but I just cant see it.


Sub Movepartcodetrial()


Dim ws As Worksheet


For Each ws In Worksheets
If Range("G4") <> "" Then
Range("G4").Cut Range("I4")
ElseIf Range("H4") <> "" Then
Range("H4").Cut Range("I4")
ElseIf Range("J4") <> "" Then
Range("J4").Cut Range("I4")
ElseIf Range("K4") <> "" Then
Range("K4").Cut Range("I4")
End If
Exit For
Next ws


End Sub

Any help would be appreciated.

 

[Scott T]

You are stopping the code from going to the next sheet since you have Exit For. Try removing it and see if your code does what you want.

 

[Fluff]

Do those cells contain formulas?
If so is the result numeric or text?

 

[Excel_Blonde]

Thanks for your quick responses.

Removing Exit For does make a difference but it doesn't run through all sheets, I think its finding the first instance and changing only that one.

The data is from a report exported into excel but it doesn't export very well. I'm using a code to un-merge all cells prior to running this code.

There are no formula's, the data being moved can be text or numeric values, sometimes a mixture of the two.

 

[Fluff]

Ok, how about

Sub Excel_Blonde()
   Dim ws As Worksheet
   
   For Each ws In Worksheets
      On Error Resume Next
      With ws.Range("G4:H4,J4:K4").SpecialCells(xlConstants)
         ws.Range("I4").Value = .Value
         .ClearContents
      End With
      On Error GoTo 0
   Next ws
End Sub

 

[Excel_Blonde]

Seems to be working perfectly! Thank you very much. Would you mind looking at the next part of my issue? Now i have the data in I4 I want to rename the sheets to that information. The issue is there can be more than 1 of the same name, I've gotten as far as the below code but now its returning an error on ws.Name = wsname (Name already taken).

Sub RenameSheets1()


Dim ws As Worksheet, wscount As Integer, wsname As String, dict
Set dict = CreateObject("scripting.Dictionary")


For Each ws In Sheets
If ws.Name <> "List" Then
If ws.Range("I4") <> "" Then
wsname = Replace(ws.Range("I4"), "/", "")
wscount = IIf(dict.Exists(wsname), dict(wsname) + 1, 1)
dict(wsname) = wscount
If wscount = 1 Then
ws.Name = wsname
Else
If wscount = 2 Then Sheets(wsname).Name = wsname & -1
End If
End If
End If

Next ws
End Sub

Sorry, I've spent about 3 days now trying to get various parts of a larger Macro to work, but my knowledge is very limited and searches have gotten me as far as I can go I think.

 

[Fluff]

How about

Sub Excel_Blonde()
   Dim ws As Worksheet
   Dim ShtName As String
   
   With CreateObject("scripting.dictionary")
      For Each ws In Worksheets
         If ws.Name <> "List" Then
            On Error Resume Next
            With ws.Range("G4:H4,J4:K4").SpecialCells(xlConstants)
               ws.Range("I4").Value = .Value
               .ClearContents
            End With
            On Error GoTo 0
            ShtName = Replace(ws.Range("I4").Value, "/", "")
            .Item(ShtName) = .Item(ShtName) + 1
            ws.Name = ShtName & "(" & .Item(ShtName) & ")"
         End If
      Next ws
   End With
End Sub

 

[Excel_Blonde]

Perfect!! Thank you very much for your help.

 

[Fluff]

You're welcome & thanks for the feedback